diff --git a/BUILD b/BUILD index a3ddec9..194cd1c 100644 --- a/BUILD +++ b/BUILD @@ -25,7 +25,10 @@ license( licenses(["notice"]) -exports_files(["LICENSE"]) +exports_files([ + "LICENSE", + "imagesave.lisp", +]) bzl_library( name = "build_rules", diff --git a/doc/rules.md b/doc/rules.md index edaee33..532c45e 100755 --- a/doc/rules.md +++ b/doc/rules.md @@ -9,8 +9,9 @@ 
 lisp_binary(name, deps, srcs, data, add_features, allow_save_lisp, block_compile,
-            block_compile_specified_only, cdeps, compile_data, image, instrument_coverage, main,
-            malloc, nowarn, order, precompile_generics, runtime, save_runtime_options, stamp, verbose)
+            block_compile_specified_only, cdeps, compile_data, helper_script, image,
+            instrument_coverage, main, malloc, nowarn, order, precompile_generics, runtime,
+            save_runtime_options, stamp, verbose)
Supports all of the same attributes as [`lisp_library`](#lisp_library), plus @@ -43,6 +44,7 @@ Example: | 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` | | cdeps | C++ dependencies (generally [`cc_library`](https://docs.bazel.build/versions/master/be/c-cpp.html#cc_library)). | List of labels | optional | `[]` | | compile_data | Data available to this target and its consumers at build time, added to the inputs of LispCompile and LispCore actions. | List of labels | optional | `[]` | +| helper_script | - | Label | optional | `None` | | image | Lisp binary used as Bazel compilation image. This should be a binary with the main function `#'bazel:main` defined in `main.lisp`. | Label | optional | `"//third_party/lisp/bazel:image"` | | instrument_coverage | Force coverage instrumentation. Possible values:

`0`: Never instrument this target. Should be used if thetarget compiles generated source files or does not compilewith coverage instrumentation.

`1`: Always instrument this target. Generally should not be used outside of tests for the coverage implementation.

`-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` | | 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: 
 lisp_test(name, deps, srcs, data, add_features, allow_save_lisp, block_compile,
-          block_compile_specified_only, cdeps, compile_data, image, instrument_coverage, main, malloc,
-          nowarn, order, precompile_generics, runtime, save_runtime_options, stamp, verbose)
+          block_compile_specified_only, cdeps, compile_data, helper_script, image,
+          instrument_coverage, main, malloc, nowarn, order, precompile_generics, runtime,
+          save_runtime_options, stamp, verbose)
Like [`lisp_binary`](#lisp_binary), for defining tests to be run with the @@ -142,6 +145,7 @@ Example: | 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` | | cdeps | C++ dependencies (generally [`cc_library`](https://docs.bazel.build/versions/master/be/c-cpp.html#cc_library)). | List of labels | optional | `[]` | | compile_data | Data available to this target and its consumers at build time, added to the inputs of LispCompile and LispCore actions. | List of labels | optional | `[]` | +| helper_script | - | Label | optional | `None` | | image | Lisp binary used as Bazel compilation image. This should be a binary with the main function `#'bazel:main` defined in `main.lisp`. | Label | optional | `"//third_party/lisp/bazel:image"` | | instrument_coverage | Force coverage instrumentation. Possible values:

`0`: Never instrument this target. Should be used if thetarget compiles generated source files or does not compilewith coverage instrumentation.

`1`: Always instrument this target. Generally should not be used outside of tests for the coverage implementation.

`-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` | | 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"` | diff --git a/imagesave.lisp b/imagesave.lisp new file mode 100644 index 0000000..48803f2 --- /dev/null +++ b/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")) diff --git a/main.lisp b/main.lisp index 73c4b5c..6565017 100644 --- a/main.lisp +++ b/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." diff --git a/rules.bzl b/rules.bzl index 6f37ee7..80d9713 100644 --- a/rules.bzl +++ b/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) diff --git a/sbcl.lisp b/sbcl.lisp index b7ee14e..7999b66 100644 --- a/sbcl.lisp +++ b/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)))