- (if purify
- (purify :root-structures root-structures
- :environment-name environment-name)
- #!-gencgc (gc) #!+gencgc (gc :full t))
- ;; FIXME: Wouldn't it be more correct to go through this list backwards
- ;; instead of forwards?
- (dolist (f *before-save-initializations*)
- (funcall f))
- (flet ((restart-lisp ()
- (handling-end-of-the-world
- (reinit)
- (dolist (f *after-save-initializations*)
- (funcall f))
- (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)))))
-\f
-;;;; functions used by worldload.lisp in CMU CL bootstrapping
-
-;;; If Name has been byte-compiled, and :RUNTIME is a feature, then load the
-;;; byte-compiled version, otherwise just do normal load.
-#+nil ; no longer needed in SBCL.. I think.. -- WHN 19990814
-(defun maybe-byte-load (name &optional (load-native t))
- (let ((bname (make-pathname
- :defaults name
- :type #.(sb!c:backend-byte-fasl-file-type))))
- (cond ((and (featurep :runtime)
- (probe-file bname))
- (load bname))
- (load-native
- (load name)))))
-
-;;; Replace a cold-loaded native object file with a byte-compiled one, if it
-;;; exists.
-#+nil ; no longer needed in SBCL.. I think.. -- WHN 19990814
-(defun byte-load-over (name)
- (load (make-pathname
- :defaults name
- :type #.(sb!c:backend-byte-fasl-file-type))
- :if-does-not-exist nil))
+ (labels ((restart-lisp ()
+ (handling-end-of-the-world
+ (reinit)
+ #!+hpux (sb!sys:%primitive sb!vm::setup-return-from-lisp-stub)
+ (progn
+ (funcall toplevel)
+ (sb!ext:quit))))
+ (foreign-bool (value)
+ (if value 1 0))
+ (save-core (gc)
+ (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)))
+ (without-gcing
+ (save name
+ (get-lisp-obj-address #'restart-lisp)
+ (foreign-bool executable)
+ (foreign-bool save-runtime-options))))))
+ ;; Save the restart function into a static symbol, to allow GC-AND-SAVE
+ ;; access to it even after the GC has moved it.
+ #!+gencgc
+ (setf sb!vm::*restart-lisp-function* #'restart-lisp)
+ (cond #!-gencgc
+ (purify
+ (purify :root-structures root-structures
+ :environment-name environment-name)
+ (save-core nil))
+ (t
+ ;; Compact the environment even though we're skipping the
+ ;; other purification stages.
+ (sb!kernel::compact-environment-aux "Auxiliary" 200)
+ (save-core t)))))
+
+(defun deinit ()
+ (call-hooks "save" *save-hooks*)
+ (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)
+ (deinit-finalizers))