Optimize MAKE-ARRAY on unknown element-type.

[sbcl.git] / src / code / save.lisp

diff --git a/src/code/save.lisp b/src/code/save.lisp
index 059f132..7568ede 100644 (file)
--- a/src/code/save.lisp
+++ b/src/code/save.lisp
@@ -21,13 +21,19 @@
   (file c-string)
   (initial-fun (unsigned #.sb!vm:n-word-bits))
   (prepend-runtime int)
   (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)
+  (application-type int))

 
 #!+gencgc
 (define-alien-routine "gc_and_save" void
   (file c-string)
   (prepend-runtime 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)
+  (application-type int))

 
 #!+gencgc
 (defvar sb!vm::*restart-lisp-function*)
 
 #!+gencgc
 (defvar sb!vm::*restart-lisp-function*)

@@ -38,7 +44,10 @@
                                          (save-runtime-options nil)
                                          (purify t)
                                          (root-structures ())
                                          (save-runtime-options nil)
                                          (purify t)
                                          (root-structures ())

-                                         (environment-name "auxiliary"))
+                                         (environment-name "auxiliary")
+                                         (compression nil)
+                                         #!+win32
+                                         (application-type :console))

   #!+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.
   #!+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.

@@ -50,7 +59,10 @@ The following &KEY arguments are defined:
      The function to run when the created core file is resumed. The
      default function handles command line toplevel option processing
      and runs the top level read-eval-print loop. This function returning
      The function to run when the created core file is resumed. The
      default function handles command line toplevel option processing
      and runs the top level read-eval-print loop. This function returning

-     is equivalent to (SB-EXT:QUIT :UNIX-STATUS 0) being called.
+     is equivalent to (SB-EXT:EXIT :CODE 0) being called.
+
+     TOPLEVEL functions should always provide an ABORT restart: otherwise
+     code they call will run without one.

 
   :EXECUTABLE
      If true, arrange to combine the SBCL runtime and the core image
 
   :EXECUTABLE
      If true, arrange to combine the SBCL runtime and the core image

@@ -85,6 +97,19 @@ The following &KEY arguments are defined:
      This is also passed to the PURIFY function when :PURIFY is T.
      (rarely used)
 
      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).
+
+  :APPLICATION-TYPE
+     Present only on Windows and is meaningful only with :EXECUTABLE T.
+     Specifies the subsystem of the executable, :CONSOLE or :GUI.
+     The notable difference is that :GUI doesn't automatically create a console
+     window. The default is :CONSOLE.
+

 The save/load process changes the values of some global variables:
 
   *STANDARD-OUTPUT*, *DEBUG-IO*, etc.
 The save/load process changes the values of some global variables:
 
   *STANDARD-OUTPUT*, *DEBUG-IO*, etc.

@@ -95,7 +120,7 @@ The save/load process changes the values of some global variables:
     This is reinitialized to reflect the working directory where the
     saved core is loaded.
 
     This is reinitialized to reflect the working directory where the
     saved core is loaded.
 

-SAVE-LISP-AND-DIE interacts with SB-ALIEN:LOAD-FOREIGN-OBJECT: see its
+SAVE-LISP-AND-DIE interacts with SB-ALIEN:LOAD-SHARED-OBJECT: see its

 documentation for details.
 
 On threaded platforms only a single thread may remain running after
 documentation for details.
 
 On threaded platforms only a single thread may remain running after

@@ -116,6 +141,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))
 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
   (tune-hashtable-sizes-of-all-packages)
   (deinit)
   ;; FIXME: Would it be possible to unmix the PURIFY logic from this

@@ -126,26 +158,41 @@ sufficiently motivated to do lengthy fixes."
              (handling-end-of-the-world
                (reinit)
                #!+hpux (sb!sys:%primitive sb!vm::setup-return-from-lisp-stub)
              (handling-end-of-the-world
                (reinit)
                #!+hpux (sb!sys:%primitive sb!vm::setup-return-from-lisp-stub)

-               (progn
-                 (funcall toplevel)
-                 (sb!ext:quit))))
+               (funcall toplevel)))

            (foreign-bool (value)
              (if value 1 0))
            (save-core (gc)
            (foreign-bool (value)
              (if value 1 0))
            (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)
-                                      (foreign-bool executable)
-                                      (foreign-bool save-runtime-options)))
-             (without-gcing
-              (save (unix-namestring core-file-name nil)
-                    (get-lisp-obj-address #'restart-lisp)
-                    (foreign-bool executable)
-                    (foreign-bool save-runtime-options)))))
+             (let ((name (native-namestring
+                          (physicalize-pathname core-file-name)
+                          :as-file t)))
+               (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 name
+                                        (foreign-bool executable)
+                                        (foreign-bool save-runtime-options)
+                                        (foreign-bool compression)
+                                        (or compression 0)
+                                        #!+win32
+                                        (ecase application-type
+                                          (:console 0)
+                                          (:gui 1))
+                                        #!-win32 0))
+               (without-gcing
+                 (save name
+                       (get-lisp-obj-address #'restart-lisp)
+                       (foreign-bool executable)
+                       (foreign-bool save-runtime-options)
+                       (foreign-bool compression)
+                       (or compression 0)
+                       #!+win32
+                       (ecase application-type
+                         (:console 0)
+                         (:gui 1))
+                       #!-win32 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
     ;; Save the restart function into a static symbol, to allow GC-AND-SAVE
     ;; access to it even after the GC has moved it.
     #!+gencgc

@@ -159,15 +206,21 @@ sufficiently motivated to do lengthy fixes."
            ;; Compact the environment even though we're skipping the
            ;; other purification stages.
            (sb!kernel::compact-environment-aux "Auxiliary" 200)
            ;; Compact the environment even though we're skipping the
            ;; other purification stages.
            (sb!kernel::compact-environment-aux "Auxiliary" 200)

-           (save-core t)))))
+           (save-core t)))
+    ;; Something went very wrong -- reinitialize to have a prayer
+    ;; of being able to report the error.
+    (reinit)
+    (error "Could not save core.")))

 
 (defun deinit ()
   (call-hooks "save" *save-hooks*)
 
 (defun deinit ()
   (call-hooks "save" *save-hooks*)

+  #!+sb-wtimer
+  (itimer-emulation-deinit)

   (when (rest (sb!thread:list-all-threads))
     (error "Cannot save core with multiple threads running."))
   (float-deinit)
   (profile-deinit)
   (when (rest (sb!thread:list-all-threads))
     (error "Cannot save core with multiple threads running."))
   (float-deinit)
   (profile-deinit)

-  (debug-deinit)

   (foreign-deinit)
   (stream-deinit)
   (foreign-deinit)
   (stream-deinit)

-  (deinit-finalizers))
+  (deinit-finalizers)
+  (drop-all-hash-caches))