diff options
author | Sean Whitton <spwhitton@spwhitton.name> | 2021-11-14 20:45:55 -0700 |
---|---|---|
committer | Sean Whitton <spwhitton@spwhitton.name> | 2021-11-14 21:22:43 -0700 |
commit | edc051f601b7f8565b51b64b11a23d285e346fbd (patch) | |
tree | b3ec811ded7f0e5ea0a7811ec34b5624891d581a | |
parent | 33ab1ff0607ea82fdabb6cae423248d2040b3286 (diff) | |
download | consfigurator-edc051f601b7f8565b51b64b11a23d285e346fbd.tar.gz |
fixes to permit dumping and reinvoking and then dumping again
- Update stored checksums when reinvoking, else the SBCL-specific checks in
%DUMP-CONSFIGURATOR-IN-GRANDCHILD will always fail in reinvoked images.
- Also update *US* when reinvoking; previously, the code in IMAGE-DUMPED to
skip the dump when the target filename is the executable we're running from
was using the old value of *US* and thus would probably never skip the dump.
- Don't abort the dump just because the target filename is the executable
we're running from (I believe the restriction was accidentally included when
refactoring a previous work-in-progress version of fbe55a361f).
- %DUMP-CONSFIGURATOR-IN-GRANDCHILD: ensure we remove the hook which evaluates
the parent process's request so it doesn't get run again.
Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>
-rw-r--r-- | src/image.lisp | 50 |
1 files changed, 36 insertions, 14 deletions
diff --git a/src/image.lisp b/src/image.lisp index eb27942..c309442 100644 --- a/src/image.lisp +++ b/src/image.lisp @@ -102,12 +102,26 @@ Thus, PREREQUEST must not start up any threads." ,(wrap-grandchild-request request) (,out ,err ,exit) ,@forms)) -#+sbcl (defvar *sbcl-core-cksum* (local-cksum sb-ext:*core-pathname*)) -#+sbcl (defvar *sbcl-runtime-cksum* (local-cksum sb-ext:*runtime-pathname*)) - -(defvar *us* - #+sbcl sb-ext:*runtime-pathname* - #+(and linux (not sbcl)) (resolve-symlinks "/proc/self/exe")) +;; As SBCL does not expose the build-id, use two checksums. +#+sbcl (defvar *sbcl-core-cksum*) #+sbcl (defvar *sbcl-runtime-cksum*) +#+sbcl (uiop:register-image-restore-hook + (lambda () + ;; Something like an INIT-HOOKS-CONNECTION might have already + ;; rendered these files inaccessible, in which case just clear out + ;; the old checksums. + (setq + *sbcl-core-cksum* (and (file-exists-p sb-ext:*core-pathname*) + (local-cksum sb-ext:*core-pathname*)) + *sbcl-runtime-cksum* (and (file-exists-p sb-ext:*runtime-pathname*) + (local-cksum sb-ext:*runtime-pathname*)))) + t) + +(defvar *us*) +(uiop:register-image-restore-hook + (lambda () + (setq *us* #+sbcl sb-ext:*runtime-pathname* + #+(and linux (not sbcl)) (resolve-symlinks "/proc/self/exe"))) + t) (define-simple-error wrong-execution-context-for-image-dump (aborted-change)) @@ -124,21 +138,29 @@ Thus, PREREQUEST must not start up any threads." path)) ;; Check that we can dump. #+sbcl - (unless (and (not (pathname-equal filename *us*)) + (unless (and *sbcl-core-cksum* (file-exists-p sb-ext:*core-pathname*) - (file-exists-p sb-ext:*runtime-pathname*) - ;; As SBCL does not expose the build-id, use two checksums. - (= *sbcl-core-cksum* - (local-cksum sb-ext:*core-pathname*)) - (= *sbcl-runtime-cksum* - (local-cksum sb-ext:*runtime-pathname*))) + (= *sbcl-core-cksum* (local-cksum sb-ext:*core-pathname*)) + ;; If we're running from a dumped executable then the runtime + ;; and core pathnames are the same, so no need to check. + (or (eql :executable uiop:*image-dumped-p*) + (and *sbcl-runtime-cksum* + (file-exists-p sb-ext:*runtime-pathname*) + (= *sbcl-runtime-cksum* + (local-cksum sb-ext:*runtime-pathname*))))) (wrong-execution-context-for-image-dump "Couldn't dump executable image because same SBCL build unavailable.")) ;; Perform the image dump. (with-fork-request nil `(progn ,pre-dump (nix:umask #o077) - (uiop:register-image-restore-hook (lambda () (eval ',form)) nil) + (uiop:register-image-restore-hook + (named-lambda hook () + ;; Remove ourselves so that a dump-and-reinvoke by the + ;; reinvoked image will not try to run us again. + (deletef uiop:*image-restore-hook* #'hook) + (eval ',form)) + nil) (uiop:dump-image ,filename :executable t)) (out err exit) (declare (ignore out)) |