say what

BUILD

@@ -25,7 +25,10 @@ license(
 
 licenses(["notice"])
 
-exports_files(["LICENSE"])
+exports_files([
+    "LICENSE",
+    "imagesave.lisp",
+])
 
 bzl_library(
     name = "build_rules",

doc/rules.md

@@ -9,8 +9,9 @@
 
 <pre>
 lisp_binary(<a href="#lisp_binary-name">name</a>, <a href="#lisp_binary-deps">deps</a>, <a href="#lisp_binary-srcs">srcs</a>, <a href="#lisp_binary-data">data</a>, <a href="#lisp_binary-add_features">add_features</a>, <a href="#lisp_binary-allow_save_lisp">allow_save_lisp</a>, <a href="#lisp_binary-block_compile">block_compile</a>,
-            <a href="#lisp_binary-block_compile_specified_only">block_compile_specified_only</a>, <a href="#lisp_binary-cdeps">cdeps</a>, <a href="#lisp_binary-compile_data">compile_data</a>, <a href="#lisp_binary-image">image</a>, <a href="#lisp_binary-instrument_coverage">instrument_coverage</a>, <a href="#lisp_binary-main">main</a>,
-            <a href="#lisp_binary-malloc">malloc</a>, <a href="#lisp_binary-nowarn">nowarn</a>, <a href="#lisp_binary-order">order</a>, <a href="#lisp_binary-precompile_generics">precompile_generics</a>, <a href="#lisp_binary-runtime">runtime</a>, <a href="#lisp_binary-save_runtime_options">save_runtime_options</a>, <a href="#lisp_binary-stamp">stamp</a>, <a href="#lisp_binary-verbose">verbose</a>)
+            <a href="#lisp_binary-block_compile_specified_only">block_compile_specified_only</a>, <a href="#lisp_binary-cdeps">cdeps</a>, <a href="#lisp_binary-compile_data">compile_data</a>, <a href="#lisp_binary-helper_script">helper_script</a>, <a href="#lisp_binary-image">image</a>,
+            <a href="#lisp_binary-instrument_coverage">instrument_coverage</a>, <a href="#lisp_binary-main">main</a>, <a href="#lisp_binary-malloc">malloc</a>, <a href="#lisp_binary-nowarn">nowarn</a>, <a href="#lisp_binary-order">order</a>, <a href="#lisp_binary-precompile_generics">precompile_generics</a>, <a href="#lisp_binary-runtime">runtime</a>,
+            <a href="#lisp_binary-save_runtime_options">save_runtime_options</a>, <a href="#lisp_binary-stamp">stamp</a>, <a href="#lisp_binary-verbose">verbose</a>)
 </pre>
 
 Supports all of the same attributes as [`lisp_library`](#lisp_library), plus
@@ -43,6 +44,7 @@ Example:
 | <a id="lisp_binary-block_compile_specified_only"></a>block_compile_specified_only |  If true, block compilation only considers multiple top-level forms together if those are between explicit (START-BLOCK) and (END-BLOCK).   | Boolean | optional |  `False`  |
 | <a id="lisp_binary-cdeps"></a>cdeps |  C++ dependencies (generally [`cc_library`](https://docs.bazel.build/versions/master/be/c-cpp.html#cc_library)).   | <a href="https://bazel.build/concepts/labels">List of labels</a> | optional |  `[]`  |
 | <a id="lisp_binary-compile_data"></a>compile_data |  Data available to this target and its consumers at build time, added to the inputs of LispCompile and LispCore actions.   | <a href="https://bazel.build/concepts/labels">List of labels</a> | optional |  `[]`  |
+| <a id="lisp_binary-helper_script"></a>helper_script |  -   | <a href="https://bazel.build/concepts/labels">Label</a> | optional |  `None`  |
 | <a id="lisp_binary-image"></a>image |  Lisp binary used as Bazel compilation image. This should be a binary with the main function `#'bazel:main` defined in `main.lisp`.   | <a href="https://bazel.build/concepts/labels">Label</a> | optional |  `"//third_party/lisp/bazel:image"`  |
 | <a id="lisp_binary-instrument_coverage"></a>instrument_coverage |  Force coverage instrumentation. Possible values:<br><br>`0`: Never instrument this target. Should be used if thetarget compiles generated source files or does not compilewith coverage instrumentation.<br><br>`1`: Always instrument this target. Generally should not be used outside of tests for the coverage implementation.<br><br>`-1` (default): If coverage data collection is enabled, instrument this target per [`--instrumentation_filter](https://docs.bazel.build/versions/master/command-line-reference.html#flag--instrumentation_filter).`   | Integer | optional |  `-1`  |
 | <a id="lisp_binary-main"></a>main |  Name of function (by default in the `cl-user` package) or snippet of Lisp code to run when starting the binary. `"nil"` or `"t"` to start the default REPL. Can be overridden by naming a function (or `nil` or `t`) in the `LISP_MAIN` environment variable.   | String | optional |  `"main"`  |
@@ -105,8 +107,9 @@ Example:
 
 <pre>
 lisp_test(<a href="#lisp_test-name">name</a>, <a href="#lisp_test-deps">deps</a>, <a href="#lisp_test-srcs">srcs</a>, <a href="#lisp_test-data">data</a>, <a href="#lisp_test-add_features">add_features</a>, <a href="#lisp_test-allow_save_lisp">allow_save_lisp</a>, <a href="#lisp_test-block_compile">block_compile</a>,
-          <a href="#lisp_test-block_compile_specified_only">block_compile_specified_only</a>, <a href="#lisp_test-cdeps">cdeps</a>, <a href="#lisp_test-compile_data">compile_data</a>, <a href="#lisp_test-image">image</a>, <a href="#lisp_test-instrument_coverage">instrument_coverage</a>, <a href="#lisp_test-main">main</a>, <a href="#lisp_test-malloc">malloc</a>,
-          <a href="#lisp_test-nowarn">nowarn</a>, <a href="#lisp_test-order">order</a>, <a href="#lisp_test-precompile_generics">precompile_generics</a>, <a href="#lisp_test-runtime">runtime</a>, <a href="#lisp_test-save_runtime_options">save_runtime_options</a>, <a href="#lisp_test-stamp">stamp</a>, <a href="#lisp_test-verbose">verbose</a>)
+          <a href="#lisp_test-block_compile_specified_only">block_compile_specified_only</a>, <a href="#lisp_test-cdeps">cdeps</a>, <a href="#lisp_test-compile_data">compile_data</a>, <a href="#lisp_test-helper_script">helper_script</a>, <a href="#lisp_test-image">image</a>,
+          <a href="#lisp_test-instrument_coverage">instrument_coverage</a>, <a href="#lisp_test-main">main</a>, <a href="#lisp_test-malloc">malloc</a>, <a href="#lisp_test-nowarn">nowarn</a>, <a href="#lisp_test-order">order</a>, <a href="#lisp_test-precompile_generics">precompile_generics</a>, <a href="#lisp_test-runtime">runtime</a>,
+          <a href="#lisp_test-save_runtime_options">save_runtime_options</a>, <a href="#lisp_test-stamp">stamp</a>, <a href="#lisp_test-verbose">verbose</a>)
 </pre>
 
 Like [`lisp_binary`](#lisp_binary), for defining tests to be run with the
@@ -142,6 +145,7 @@ Example:
 | <a id="lisp_test-block_compile_specified_only"></a>block_compile_specified_only |  If true, block compilation only considers multiple top-level forms together if those are between explicit (START-BLOCK) and (END-BLOCK).   | Boolean | optional |  `False`  |
 | <a id="lisp_test-cdeps"></a>cdeps |  C++ dependencies (generally [`cc_library`](https://docs.bazel.build/versions/master/be/c-cpp.html#cc_library)).   | <a href="https://bazel.build/concepts/labels">List of labels</a> | optional |  `[]`  |
 | <a id="lisp_test-compile_data"></a>compile_data |  Data available to this target and its consumers at build time, added to the inputs of LispCompile and LispCore actions.   | <a href="https://bazel.build/concepts/labels">List of labels</a> | optional |  `[]`  |
+| <a id="lisp_test-helper_script"></a>helper_script |  -   | <a href="https://bazel.build/concepts/labels">Label</a> | optional |  `None`  |
 | <a id="lisp_test-image"></a>image |  Lisp binary used as Bazel compilation image. This should be a binary with the main function `#'bazel:main` defined in `main.lisp`.   | <a href="https://bazel.build/concepts/labels">Label</a> | optional |  `"//third_party/lisp/bazel:image"`  |
 | <a id="lisp_test-instrument_coverage"></a>instrument_coverage |  Force coverage instrumentation. Possible values:<br><br>`0`: Never instrument this target. Should be used if thetarget compiles generated source files or does not compilewith coverage instrumentation.<br><br>`1`: Always instrument this target. Generally should not be used outside of tests for the coverage implementation.<br><br>`-1` (default): If coverage data collection is enabled, instrument this target per [`--instrumentation_filter](https://docs.bazel.build/versions/master/command-line-reference.html#flag--instrumentation_filter).`   | Integer | optional |  `-1`  |
 | <a id="lisp_test-main"></a>main |  Name of function (by default in the `cl-user` package) or snippet of Lisp code to run when starting the binary. `"nil"` or `"t"` to start the default REPL. Can be overridden by naming a function (or `nil` or `t`) in the `LISP_MAIN` environment variable.   | String | optional |  `"main"`  |

imagesave.lisp

@@ -0,0 +1,68 @@
+#|(in-package sb-impl)
+(defun safe-gethash3 (key table default)
+  (let ((layout (sb-kernel:%instance-layout table)))
+    (if (/= 0 (sb-kernel:get-lisp-obj-address layout))
+        (funcall (hash-table-gethash-impl table) key table default)
+        (let ((s #.(format nil "table messup~%")))
+          (sb-unix:unix-write 2 s 0 (length s))
+          (sb-ext:search-roots (sb-ext:make-weak-pointer table) :print :verbose)
+          (error "can't go on- table ~X borked"
+                 (sb-kernel:get-lisp-obj-address table))))))
+(compile 'safe-gethash3)
+(setf (symbol-function 'gethash3) #'safe-gethash3)
+
+;(defvar *in-convert-table* nil)
+;(defun wrap-internal-make-hash-table (realfun &rest args)
+;  (let ((result (apply realfun args)))
+;    (when (and *in-convert-table* (neq (heap-allocated-p result) :dynamic))
+;      (let ((s (format nil "table ~x not on heap: ~s~%"
+;                       (sb-kernel:get-lisp-obj-address result)
+;                       (sb-debug:list-backtrace :count 20))))
+;        (sb-sys:with-pinned-objects (s)
+;          (sb-unix:unix-write 2 s 0 (length s)))))
+;    result))
+;(compile 'wrap-internal-make-hash-table)
+;(sb-int:encapsulate 'sb-impl::%make-hash-table 'trace #'wrap-internal-make-hash-table)
+
+(in-package sb-pcl)
+(defun wrap-convert-table (realfun a b c)
+  (let ((result (funcall realfun a b c)))
+    (when (and (hash-table-p result)
+               (plusp (hash-table-count result))
+               (neq (heap-allocated-p result) :dynamic))
+      (let ((s (with-output-to-string (s)
+                 (format s "converted table ~x keys" (sb-kernel:get-lisp-obj-address result))
+                 (maphash (lambda (k v) v (format s " ~s" k)) result)
+                 (format s "~%~a~%" (sb-debug:list-backtrace :count 20)))))
+        (setq s (coerce s 'base-string))
+        (sb-sys:with-pinned-objects (s)
+          (sb-unix:unix-write 2 s 0 (length s)))))
+    result))
+(compile 'wrap-convert-table)
+(sb-int:encapsulate 'convert-table 'trace #'wrap-convert-table)
+
+(in-package "CL-USER")
+|#
+;; Fancy save steps
+(defun save-and-exit (name &key toplevel save-runtime-options verbose
+                           precompile-generics executable)
+  "Saves the current Lisp image and dies.
+ Arguments:
+  NAME - the file name to save the image.
+  TOPLEVEL - the name of the toplevel function.
+  SAVE-RUNTIME-OPTIONS - indicates if the runtime options shall be saved to the C runtime.
+      This is usually permanent.
+  VERBOSE - if true, the output streams are not muted before dumping the image.
+  PRECOMPILE-GENERICS - will precompile the generic functions before saving.
+  EXECUTABLE - Whether to combine the launcher with the image to create an executable."
+  (unintern 'save-and-exit)
+;  (disable-debugger)
+;  (when precompile-generics
+;    (bazel.sbcl::precompile-generic-functions :verbose bazel.log:*verbose*))
+;  (unless verbose (bazel.sbcl:mute-output-streams))
+;  (fold-identical-code :aggressive t)
+;  (setf (extern-alien "gc_coalesce_string_literals" char) 2)
+  (save-lisp-and-die name :executable executable
+                          :toplevel toplevel
+                          :save-runtime-options save-runtime-options)
+  (sb-int:bug "Unreachable"))

main.lisp

@@ -551,14 +551,18 @@ If LISP_MAIN is NIL or T it will call top-level REPL as well."
   (funcall-named "UIOP:CALL-IMAGE-DUMP-HOOK")
   ;; Set to a sane value.
   (in-package "COMMON-LISP-USER")
-  ;; Finally call the Lisp implementation function.
-  (save-lisp-and-die
-   name
-   :toplevel #'restart-image
-   :save-runtime-options save-runtime-options
-   :precompile-generics precompile-generics
-   :executable executable
-   :verbose (plusp *verbose*)))
+  (dolist (candidate '("lisp/devtools/bazel/imagesave.lisp"
+                       "third_party/lisp/bazel/imagesave.lisp"))
+    (when (probe-file candidate)
+      (load candidate)
+      (funcall (intern "SAVE-AND-EXIT")
+               name
+               :toplevel #'restart-image
+               :save-runtime-options save-runtime-options
+               :precompile-generics precompile-generics
+               :executable executable
+               :verbose (plusp *verbose*))))
+  (sb-ext:save-lisp-and-die name :toplevel #'restart-image :executable t))
 
 (defun set-optimization-mode (optimization-mode)
   "Proclaim the optimization settings based on the OPTIMIZATION-MODE."

rules.bzl

@@ -200,6 +200,10 @@ _LISP_BINARY_ATTRS.update({
         doc = ("SBCL C++ dependencies. Consumers should generally omit this " +
                "attr and use the default value."),
     ),
+    "helper_script": attr.label(
+        default = None,
+        allow_single_file = True,
+    ),
     "_elfinate": attr.label(
         default = Label(_ELFINATE),
         executable = True,
@@ -674,7 +678,10 @@ def _lisp_binary_impl(ctx):
         content = content,
     )
 
-    inputs = [specs]
+    if ctx.file.helper_script == None:
+        inputs = [specs]
+    else:
+        inputs = [specs, ctx.file.helper_script]
     inputs.extend(fasls)
     inputs.extend(hashes)
     inputs.extend(warnings)

sbcl.lisp

@@ -109,15 +109,6 @@
   (setf (extern-alien "lisp_startup_options" int) 1)
   nil)
 
-(defun terminate-other-threads ()
-  "Terminates all non-system threads but the current one."
-  (let ((threads (remove-if (lambda (x)
-                              (or (thread-ephemeral-p x)
-                                  (eq x *current-thread*)))
-                            (list-all-threads))))
-    (mapc #'terminate-thread threads)
-    (mapc (lambda (thread) (join-thread thread :default nil)) threads)))
-
 (defun name-closure (closure name)
   "Return CLOSURE with the NAME changed, so it prints nicely."
   ;; This is not necessary, except for debugging and aesthetics.
@@ -278,32 +269,6 @@
 ;;; Generate an image.
 ;;;
 
-(defun save-lisp-and-die (name &key toplevel save-runtime-options verbose
-                               precompile-generics executable)
-  "Saves the current Lisp image and dies.
- Arguments:
-  NAME - the file name to save the image.
-  TOPLEVEL - the name of the toplevel function.
-  SAVE-RUNTIME-OPTIONS - indicates if the runtime options shall be saved to the C runtime.
-      This is usually permanent.
-  VERBOSE - if true, the output streams are not muted before dumping the image.
-  PRECOMPILE-GENERICS - will precompile the generic functions before saving.
-  EXECUTABLE - Whether to combine the launcher with the image to create an executable."
-  (sb-ext:disable-debugger)
-  (terminate-other-threads)
-  (when precompile-generics
-    (precompile-generic-functions :verbose bazel.log:*verbose*))
-  (unless verbose (mute-output-streams))
-  (sb-ext:fold-identical-code :aggressive t)
-  (setf (extern-alien "gc_coalesce_string_literals" char) 2)
-  (sb-ext:save-lisp-and-die
-   name
-   :executable executable
-   :toplevel toplevel
-   :save-runtime-options save-runtime-options)
-
-  (assert (not "Expected the image to survive after save-lisp-and-die."))) ; NOLINT
-
 (defun set-interpret-mode (compile-mode)
   "Set the mode of eval to :interpret if COMPILE-MODE is :LOAD. Otherwise, set it to :COMPILE."
   (declare (optimize (speed 1) (safety 3) (compilation-speed 1) (debug 1)))