From 7c6a74fba205d01d52cca7720d1d30879feb20d8 Mon Sep 17 00:00:00 2001 From: Jonathan Godbout Date: Wed, 10 Jun 2026 10:50:33 -0700 Subject: [PATCH] Update METADATA Copybara presubmit block to extended_options format PiperOrigin-RevId: 929951428 --- .bazelversion | 1 + .github/workflows/ci.yml | 26 + BUILD | 63 ++- BUILD.sbcl | 2 + README.md | 9 - doc/rules.md | 107 ++-- elfconvert.sh | 36 +- faslkludge.lisp | 11 + imagesave.lisp | 67 ++- main.lisp | 763 +++++++++------------------ mangler.lisp | 39 ++ provider.bzl | 19 +- repositories.bzl | 19 +- rule-tests/BUILD | 221 +------- rule-tests/tests.bzl | 80 ++- rules.bzl | 372 ++++++------- sbcl.lisp | 203 +++---- test/BUILD | 76 +-- test/circular1.lisp | 13 - test/circular2.lisp | 13 - test/circular3.lisp | 13 - test/features-test.lisp | 6 +- test/stack-alloc.lisp | 20 - test/test-circular.lisp | 10 - test/undefined-macro-definition.lisp | 9 - test/undefined-macro-reference.lisp | 9 - test/undefined-macro-test.lisp | 45 -- test/wrong-arg-count-test.lisp | 24 - test/wrong-arg-count.lisp | 13 - utils.lisp | 108 +--- warning.lisp | 203 +------ 31 files changed, 788 insertions(+), 1812 deletions(-) create mode 100644 .bazelversion create mode 100644 .github/workflows/ci.yml create mode 100644 faslkludge.lisp create mode 100644 mangler.lisp delete mode 100644 test/circular1.lisp delete mode 100644 test/circular2.lisp delete mode 100644 test/circular3.lisp delete mode 100644 test/stack-alloc.lisp delete mode 100644 test/test-circular.lisp delete mode 100644 test/undefined-macro-definition.lisp delete mode 100644 test/undefined-macro-reference.lisp delete mode 100644 test/undefined-macro-test.lisp delete mode 100644 test/wrong-arg-count-test.lisp delete mode 100644 test/wrong-arg-count.lisp diff --git a/.bazelversion b/.bazelversion new file mode 100644 index 0000000..815da58 --- /dev/null +++ b/.bazelversion @@ -0,0 +1 @@ +7.4.1 diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml new file mode 100644 index 0000000..cc7060c --- /dev/null +++ b/.github/workflows/ci.yml @@ -0,0 +1,26 @@ +name: CI + +on: + push: + branches: [ master, main ] + pull_request: + branches: [ master, main ] + +jobs: + test: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v4 + + - name: Install SBCL + run: | + sudo apt-get update + sudo apt-get install -y sbcl + + - name: Build Lisp Files + run: | + bazel build --enable_bzlmod=false //... + + - name: Run Tests + run: | + bazel test --enable_bzlmod=false --test_output=errors //... diff --git a/BUILD b/BUILD index 194cd1c..5ead08e 100644 --- a/BUILD +++ b/BUILD @@ -12,22 +12,15 @@ # more info about this package. load("@bazel_skylib//:bzl_library.bzl", "bzl_library") -load("@bazel_skylib//rules:common_settings.bzl", "bool_flag") -load("@bazel_tools//tools/build_defs/license:license.bzl", "license") load("@io_bazel_stardoc//stardoc:stardoc.bzl", "stardoc") - -package(default_applicable_licenses = ["//:license"]) - -license( - name = "license", - package_name = "bazel", -) +load(":rules.bzl", "lisp_test") licenses(["notice"]) exports_files([ "LICENSE", "imagesave.lisp", + "sbcl.lisp", ]) bzl_library( @@ -36,7 +29,8 @@ bzl_library( visibility = ["//visibility:public"], deps = [ "@bazel_skylib//rules:common_settings", - "@rules_cc//cc:find_cc_toolchain.bzl", + "@rules_cc//cc:find_cc_toolchain_bzl", + "@rules_cc//cc/common", ], ) @@ -73,24 +67,23 @@ alias( visibility = ["//visibility:public"], ) -genrule( - name = "make-image", +[genrule( + name = "make-lfc-" + arch, srcs = [ "utils.lisp", "warning.lisp", "log.lisp", "sbcl.lisp", "main.lisp", - "@local_sbcl//:contrib/sb-md5", - "@local_sbcl//:contrib/sb-rotate-byte", "@local_sbcl//:core", "@local_sbcl//:sbcl", ], - outs = ["image"], + outs = ["lfc." + arch], # Lisp file compiler cmd = ( "$(location @local_sbcl//:sbcl)" + - " --noinform" + - " --eval '(setf sb-ext:*evaluator-mode* :compile)'" + + """ --eval '(sb-ext:unlock-package :sb-vm)'""" + + """ --eval '(setf sb-ext:*evaluator-mode* :compile + #+x86-64 sb-vm::*eager-tls-assignment* #+x86-64 t)'""" + " --load '$(location utils.lisp)'" + " --load '$(location warning.lisp)'" + " --load '$(location log.lisp)'" + @@ -100,9 +93,37 @@ genrule( ), executable = 1, output_to_bindir = 1, + # tags can't involve "select" which is why this uses one rule per arch + tags = ["requires-arch:" + arch], + visibility = ["//visibility:public"], +) for arch in [ + "arm", + "x86", +]] + +alias( + name = "lfc", + actual = select({ + "@platforms//cpu:aarch64": "lfc.arm", + "//conditions:default": "lfc.x86", + }), visibility = ["//visibility:public"], ) +genrule( + name = "make-test-image", + srcs = [ + ":lfc", + "faslkludge.lisp", + ], + outs = ["test-image"], + cmd = "LISP_MAIN=t $(location :lfc) --load $(location faslkludge.lisp) --eval " + + "'(bazel.main:save-image \"$@\" (quote bazel.main:main) :executable t)'", + executable = 1, + output_to_bindir = 1, + visibility = ["__subpackages__"], +) + # Elfinator reads an SBCL-native core file and produces two outputs: # (1) an assembly-language file with a '.text' section whose contents # are the code components from the input core file. @@ -118,7 +139,6 @@ sh_binary( "elfconvert.sh", ], data = [ - "@local_sbcl//:core", "@local_sbcl//:sbcl", "@sbcl//:tools-for-build/corefile.lisp", "@sbcl//:tools-for-build/editcore.lisp", @@ -127,8 +147,7 @@ sh_binary( visibility = ["//visibility:public"], ) -bool_flag( - name = "additional_dynamic_load_outputs", - build_setting_default = False, - visibility = ["//visibility:public"], +lisp_test( + name = "mangler", + srcs = ["mangler.lisp"], ) diff --git a/BUILD.sbcl b/BUILD.sbcl index 07e2d80..2673cb1 100644 --- a/BUILD.sbcl +++ b/BUILD.sbcl @@ -6,4 +6,6 @@ exports_files([ "tools-for-build/corefile.lisp", "tools-for-build/editcore.lisp", + "tools-for-build/elftool.lisp", + "contrib/sb-cover/cover.lisp", ]) diff --git a/README.md b/README.md index e399fac..5d1a2fa 100644 --- a/README.md +++ b/README.md @@ -239,15 +239,6 @@ output of `lisp_library`. For `lisp_binary` and `lisp_test`, the default output is the executable (same name as the target). -If the flag `--//:additional_dynamic_load_outputs` is -passed, `OutputGroupInfo` has the following additional fields: - -* `deps_manifest` additionally contains a plaintext representation of the - target's transitive Lisp features (prefixed with `feature:`) and transitive - source files (prefixed with `src:`). -* `dynamic_library` contains a shared object file with the target's transitive - C++ dependencies. - [Runfiles](https://docs.bazel.build/versions/master/skylark/rules.html#runfiles) ([`DefaultInfo.default_runfiles`](https://docs.bazel.build/versions/master/skylark/lib/DefaultInfo.html#default_runfiles)) are propagated from all dependencies that provide either runtime dependencies or diff --git a/doc/rules.md b/doc/rules.md index 532c45e..0d1ebd6 100755 --- a/doc/rules.md +++ b/doc/rules.md @@ -8,10 +8,12 @@ ## lisp_binary 
+load("//:rules.bzl", "lisp_binary")
+
 lisp_binary(name, deps, srcs, data, add_features, allow_save_lisp, block_compile,
             block_compile_specified_only, cdeps, compile_data, helper_script, image,
-            instrument_coverage, main, malloc, nowarn, order, precompile_generics, runtime,
-            save_runtime_options, stamp, verbose)
+            instrument_coverage, main, nowarn, precompile_generics, runtime, save_runtime_options,
+            stamp, verbose)
Supports all of the same attributes as [`lisp_library`](#lisp_library), plus @@ -36,7 +38,7 @@ Example: | :------------- | :------------- | :------------- | :------------- | :------------- | | name | A unique name for this target. | Name | required | | | deps | Common Lisp dependencies (generally [`lisp_library`](#lisp-library), but you can put [`lisp_binary`](#lisp-binary) in deps for testing). | List of labels | optional | `[]` | -| srcs | Common Lisp (`.lisp` or `.lsp`) source files. If there are multiple files in `srcs`, which other files in `srcs` are loaded before each file is compiled depends on the `order` attr. | List of labels | optional | `[]` | +| srcs | Common Lisp (`.lisp` or `.lsp`) source files. If there are multiple files in `srcs`, each is compiled with its predecessors loaded. | List of labels | optional | `[]` | | data | Data available to this target and its consumers in the runfiles directory at runtime. | List of labels | optional | `[]` | | add_features | Names of symbols (by default in the keyword package) to be added to `\*features\*` of this library and its consumers, at compile time and in the resulting binary. Note that this differs from the [`features`](https://docs.bazel.build/versions/master/be/common-definitions.html#common.features) attribute common to all build rules which controls [toolchain](https://docs.bazel.build/versions/master/toolchains.html) features. | List of strings | optional | `[]` | | allow_save_lisp | Whether to preserve the ability to run `save-lisp-and-die` instead of altering the binary format to be more compatible with C++ debugging tools (which, for example, allows you to get combined stacktraces of C/C++ and Lisp code). Must be `True` for targets used as a compilation image. | Boolean | optional | `False` | @@ -44,13 +46,11 @@ 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"` | +| helper_script | - | Label | optional | `"//:imagesave.lisp"` | +| 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 | `"//:lfc"` | | 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"` | -| malloc | Target providing a custom malloc implementation. Same as [`cc_binary.malloc`](https://docs.bazel.build/versions/master/be/c-cpp.html#cc_binary.malloc). Note that these rules do not respect [`--custom_malloc`](https://docs.bazel.build/versions/master/command-line-reference.html#flag--custom_malloc). | Label | optional | `"//third_party/tcmalloc"` | | nowarn | Suppressed Lisp warning types or warning handlers. | List of strings | optional | `[]` | -| order | Compilation order, one of:

`"serial"` (default) - Each source is compiled in an image with previous sources loaded. (Note that in this configuration you should put a comment at the top of the list of srcs if there is more than one, so that formatters like Buildozer do not change the order.)

`"multipass"` - Each source is compiled in an image with all sources loaded.

`"parallel"` - Each source is compiled independently. | String | optional | `"serial"` | | precompile_generics | If `False`, skip precompiling generic functions. | Boolean | optional | `True` | | runtime | SBCL C++ dependencies. Consumers should generally omit this attr and use the default value. | Label | optional | `"//third_party/lisp/sbcl:c-support"` | | save_runtime_options | If `False`, process SBCL runtime options at the command-line on binary startup. | Boolean | optional | `True` | @@ -63,8 +63,10 @@ Example: ## lisp_library 
+load("//:rules.bzl", "lisp_library")
+
 lisp_library(name, deps, srcs, data, add_features, block_compile, block_compile_specified_only,
-             cdeps, compile_data, image, instrument_coverage, nowarn, order, verbose)
+             cdeps, compile_data, image, instrument_coverage, nowarn, verbose)
The basic compilation unit for Lisp code. Can have Lisp dependencies @@ -87,85 +89,28 @@ Example: | :------------- | :------------- | :------------- | :------------- | :------------- | | name | A unique name for this target. | Name | required | | | deps | Common Lisp dependencies (generally [`lisp_library`](#lisp-library), but you can put [`lisp_binary`](#lisp-binary) in deps for testing). | List of labels | optional | `[]` | -| srcs | Common Lisp (`.lisp` or `.lsp`) source files. If there are multiple files in `srcs`, which other files in `srcs` are loaded before each file is compiled depends on the `order` attr. | List of labels | optional | `[]` | +| srcs | Common Lisp (`.lisp` or `.lsp`) source files. If there are multiple files in `srcs`, each is compiled with its predecessors loaded. | List of labels | optional | `[]` | | data | Data available to this target and its consumers in the runfiles directory at runtime. | List of labels | optional | `[]` | | add_features | Names of symbols (by default in the keyword package) to be added to `\*features\*` of this library and its consumers, at compile time and in the resulting binary. Note that this differs from the [`features`](https://docs.bazel.build/versions/master/be/common-definitions.html#common.features) attribute common to all build rules which controls [toolchain](https://docs.bazel.build/versions/master/toolchains.html) features. | List of strings | optional | `[]` | | block_compile | Whether to block-compile the sources. By default, this will cause sources to be block-compiled together as a single block, that behavior can be overridden by block_compile_specified_only. | Boolean | optional | `False` | | 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 | `[]` | -| 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"` | +| 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 | `"//:lfc"` | | 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` | | nowarn | Suppressed Lisp warning types or warning handlers. | List of strings | optional | `[]` | -| order | Compilation order, one of:

`"serial"` (default) - Each source is compiled in an image with previous sources loaded. (Note that in this configuration you should put a comment at the top of the list of srcs if there is more than one, so that formatters like Buildozer do not change the order.)

`"multipass"` - Each source is compiled in an image with all sources loaded.

`"parallel"` - Each source is compiled independently. | String | optional | `"serial"` | | verbose | Enable verbose debugging output when analyzing and compiling this target (`0` = none (default), `3` = max). | Integer | optional | `0` | - - -## lisp_test - -
-lisp_test(name, deps, srcs, data, add_features, allow_save_lisp, block_compile,
-          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 -[`test`](https://docs.bazel.build/versions/master/user-manual.html#test) -command. The [`main`](#lisp_test-main) attribute should name a function which -runs the tests, outputs information about failing assertions, and exits with a -non-zero exit status if there are any failures. - -Example: - - lisp_test( - name = "library-test" - srcs = ["library-test.lisp"], - main = "library-test:run-tests", - deps = [ - ":library", - "//path/to/unit-test:framework", - ], - ) - -**ATTRIBUTES** - - -| Name | Description | Type | Mandatory | Default | -| :------------- | :------------- | :------------- | :------------- | :------------- | -| name | A unique name for this target. | Name | required | | -| deps | Common Lisp dependencies (generally [`lisp_library`](#lisp-library), but you can put [`lisp_binary`](#lisp-binary) in deps for testing). | List of labels | optional | `[]` | -| srcs | Common Lisp (`.lisp` or `.lsp`) source files. If there are multiple files in `srcs`, which other files in `srcs` are loaded before each file is compiled depends on the `order` attr. | List of labels | optional | `[]` | -| data | Data available to this target and its consumers in the runfiles directory at runtime. | List of labels | optional | `[]` | -| add_features | Names of symbols (by default in the keyword package) to be added to `\*features\*` of this library and its consumers, at compile time and in the resulting binary. Note that this differs from the [`features`](https://docs.bazel.build/versions/master/be/common-definitions.html#common.features) attribute common to all build rules which controls [toolchain](https://docs.bazel.build/versions/master/toolchains.html) features. | List of strings | optional | `[]` | -| allow_save_lisp | Whether to preserve the ability to run `save-lisp-and-die` instead of altering the binary format to be more compatible with C++ debugging tools (which, for example, allows you to get combined stacktraces of C/C++ and Lisp code). Must be `True` for targets used as a compilation image. | Boolean | optional | `False` | -| block_compile | Whether to block-compile the sources. By default, this will cause sources to be block-compiled together as a single block, that behavior can be overridden by block_compile_specified_only. | Boolean | optional | `False` | -| 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"` | -| malloc | Target providing a custom malloc implementation. Same as [`cc_binary.malloc`](https://docs.bazel.build/versions/master/be/c-cpp.html#cc_binary.malloc). Note that these rules do not respect [`--custom_malloc`](https://docs.bazel.build/versions/master/command-line-reference.html#flag--custom_malloc). | Label | optional | `"//third_party/tcmalloc"` | -| nowarn | Suppressed Lisp warning types or warning handlers. | List of strings | optional | `[]` | -| order | Compilation order, one of:

`"serial"` (default) - Each source is compiled in an image with previous sources loaded. (Note that in this configuration you should put a comment at the top of the list of srcs if there is more than one, so that formatters like Buildozer do not change the order.)

`"multipass"` - Each source is compiled in an image with all sources loaded.

`"parallel"` - Each source is compiled independently. | String | optional | `"serial"` | -| precompile_generics | If `False`, skip precompiling generic functions. | Boolean | optional | `True` | -| runtime | SBCL C++ dependencies. Consumers should generally omit this attr and use the default value. | Label | optional | `"//third_party/lisp/sbcl:c-support"` | -| save_runtime_options | If `False`, process SBCL runtime options at the command-line on binary startup. | Boolean | optional | `True` | -| stamp | Same as [`cc_test.stamp`](https://docs.bazel.build/versions/master/be/c-cpp.html#cc_test.stamp). Build version stamping is disabled by default. | Integer | optional | `0` | -| verbose | Enable verbose debugging output when analyzing and compiling this target (`0` = none (default), `3` = max). | Integer | optional | `0` | - - ## lisp_compile_srcs 
+load("//:rules.bzl", "lisp_compile_srcs")
+
 lisp_compile_srcs(ctx, srcs, deps, cdeps, block_compile, block_compile_specified_only, image,
-                  add_features, nowarn, order, compile_data, verbose_level, instrument_coverage,
+                  add_features, nowarn, compile_data, verbose_level, instrument_coverage,
                   indexer_metadata)
@@ -188,7 +133,6 @@ This is the core functionality shared by the Lisp build rules. | image | Build image Target used to compile the sources. | `None` | | add_features | list of Lisp feature strings added by this target. | `[]` | | nowarn | List of suppressed warning type strings. | `[]` | -| order | Order in which to load sources, either "serial", "parallel", or "multipass". | `"serial"` | | compile_data | list of data dependency Targets whose outputs and runfiles are made available at load/compile time for this target and its consumers. | `[]` | | verbose_level | int indicating level of debugging output. | `0` | | instrument_coverage | Controls coverage instrumentation, with the following values: -1 (default) - Instruments if coverage is enabled for this target. 0 - Instruments never. 1 - Instruments always (for testing purposes). | `-1` | @@ -203,3 +147,24 @@ struct with fields: - build_flags: Args to pass to all LispCompile and LispCore actions + + +## lisp_test + +
+load("//:rules.bzl", "lisp_test")
+
+lisp_test(name, **kwargs)
+
+ +Macro wrapper on lisp_test_rule appending an extra tag + +**PARAMETERS** + + +| Name | Description | Default Value | +| :------------- | :------------- | :------------- | +| name | Rule name. | none | +| kwargs | Passed through to lisp_binary | none | + + diff --git a/elfconvert.sh b/elfconvert.sh index 206835c..07106e0 100755 --- a/elfconvert.sh +++ b/elfconvert.sh @@ -1,32 +1,14 @@ #!/bin/sh -# The runfiles of this shell script will contain either the ordinary (not MSAN) -# binary-distribution of SBCL, or MSAN depending on the build target's config. -# But we don't really want that! editcore.lisp is capable of operating on any -# SBCL core and executing in any SBCL. So this should always prefer non-msan, -# but that's infeasible because lisp/sbcl/binary-distribution:BUILD chooses -# for you which subdirectory you get, and you can't pick both. -case $SAR_ARGV0 in - *-msan*) sbcl_subdir=k8-msan ;; - *) sbcl_subdir=k8 -esac -sbcl=$RUNFILES/google3/third_party/lisp/sbcl/binary-distribution/$sbcl_subdir/bin/sbcl -args=(--noinform --dynamic-space-size 512MB) +input=$1 +output=$2 + +# This is a bit of a hack, but we don't know which "actual" file the :sbcl_exe +# alias rule picked out. A glob will find it- there can be only 1. +sbcl=`echo $RUNFILES/google3/third_party/lisp/sbcl/install/*` +args=(--dynamic-space-size 1024MB) mode='(setq *evaluator-mode* :compile)' script=$RUNFILES/google3/third_party/lisp/sbcl/src/tools-for-build/elftool -action=$1 -input=$2 -output=$3 - -case $action in - split) - exec $sbcl ${args[@]} --eval "$mode" --load $script --eval \ - '(sb-editcore:split-core "'$input'" "'$output'")' --quit ;; - copy) - exec $sbcl ${args[@]} --eval "$mode" --load $script --eval \ - '(sb-editcore::copy-to-elf-obj "'$input'" "'$output'")' --quit ;; - *) - echo Unknown command: $action - exit 1 -esac +exec $sbcl ${args[@]} --eval "$mode" --load $script --eval \ + '(sb-editcore:split-core "'$input'" "'$output'")' --quit diff --git a/faslkludge.lisp b/faslkludge.lisp new file mode 100644 index 0000000..8c0caa3 --- /dev/null +++ b/faslkludge.lisp @@ -0,0 +1,11 @@ +;;; Some tests utilize illegal zero-length fasls, and yet actually want to "load" +;;; them which is expected to silently succeed. That's just absurd, because +;;; if we're to fake creation of binary artifacts, why not either (1) do it right, +;;; or (2) mock out the loading of it too? Welll, I guess arguably this interceptor +;;; is doing the latter, which is certainly better than having a special-case in +;;; the general loading loop to ignore bogus fasls. +(sb-int:encapsulate 'bazel.main::load-file 'length-check + (compile nil + '(lambda (realfun name &rest rest) + (unless (zerop (with-open-file (in name) (file-length in))) + (apply realfun name rest))))) diff --git a/imagesave.lisp b/imagesave.lisp index dffae6e..2ef871d 100644 --- a/imagesave.lisp +++ b/imagesave.lisp @@ -1,4 +1,37 @@ ;; Fancy save steps +(defun remove-extra-debug-info () + "Removes debug info like docstrings and xrefs." + (dolist (x (sb-vm:list-allocated-objects + :all + :test (lambda (x) (typep x '(or class generic-function standard-method + package sb-kernel:closure + sb-kernel:defstruct-description))))) + (typecase x + (sb-kernel:closure + (when (documentation x 'function) + (setf (documentation x 'function) nil))) + (sb-kernel:defstruct-description + (setf (sb-kernel::dd-doc x) nil)) + (t + (when (ignore-errors (documentation x t)) ; maybe slot-unbound because ridiculous MOP + (setf (documentation x t) nil))))) + (sb-vm::map-allocated-objects + (lambda (obj type size) + (declare (ignore size)) + (when (= type sb-vm:code-header-widetag) + (dotimes (i (sb-kernel:code-n-entries obj)) + (let ((f (sb-kernel:%code-entry-point obj i))) + (setf (sb-kernel:%simple-fun-info f) 'function) + ;; Preserve source forms, assuming we want them if they exist. + (setf (sb-kernel:%simple-fun-source f) + (sb-kernel:%simple-fun-lexpr f)))))) + :all) + #+nil ; Can re-enable after ace.flag library test ceases depending on docstrings + (do-all-symbols (s) + (when (documentation s 'variable) + (setf (documentation s 'variable) nil))) + (fmakunbound 'remove-extra-debug-info)) ; remove this function too! + (defun save-and-exit (name &key toplevel save-runtime-options verbose precompile-generics executable) "Saves the current Lisp image and dies. @@ -10,14 +43,36 @@ 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." + (when (sb-c::policy sb-c::*policy* (and (= speed 3) (= debug 0))) + (remove-extra-debug-info)) (unintern 'save-and-exit) (disable-debugger) (when precompile-generics - (bazel.sbcl::precompile-generic-functions :verbose bazel.log:*verbose*)) + (let ((n 0)) + (dolist (p (remove-if (lambda (x) (not (eql (mismatch (package-name x) "CL-PROTOBUFS.") 13))) + (list-all-packages))) + (do-symbols (s p) + (when (and (fboundp s) + (sb-pcl::generic-function-p (symbol-function s)) + (not (sb-mop:generic-function-methods (symbol-function s)))) + (fmakunbound s) + (unintern s p) + (incf n)))) + (when (plusp n) (format *error-output* "~&Removed ~D generic functions~%" n))) ; NOLINT + (bazel.sbcl::precompile-generic-functions :verbose bazel.log:*verbose*) + ;; We don't bother with ICF when we don't care about precompiled GFs. + #+x86-64 (fold-identical-code :aggressive t) + ;; Similarly we perform string-deduplication only when core size is a concern. + (setf (extern-alien "gc_coalesce_string_literals" char) 2)) + ;; Not really sure what output we're trying to suppress... (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) + (let* ((is-elf-output (string= name ".o" :start1 (- (length name) 2))) + (exec-option (cond (is-elf-output + (assert (not executable)) ; a relocatable '.o' file is not executable + :elf-object) + (executable t) + (t nil)))) + (save-lisp-and-die name :toplevel toplevel + :save-runtime-options (if save-runtime-options :accept-runtime-options) + :executable exec-option)) (sb-int:bug "Unreachable")) diff --git a/main.lisp b/main.lisp index 63b364c..5261feb 100644 --- a/main.lisp +++ b/main.lisp @@ -10,9 +10,6 @@ ;;; bazel-lisp compile -v 2 -W "optional-and-key" "test.lisp" test.fasl ;;; -;; Default compilation settings for bazel-lisp. -#-dbg (declaim (optimize (speed 3) (safety 1))) - (defpackage #:bazel.main (:use #:common-lisp #+sbcl #:bazel.sbcl #:bazel.utils) (:import-from #:bazel.log @@ -23,81 +20,15 @@ (:export #:save-image ;; Main entry point for bazel-lisp #:main - ;; Splits a string by space. ;; List of all files compiled into the image with src hashes. #:*compiled-sources* - ;; A hash-map by source file name of the form-path line and column numbers. - #:*path-locations* - ;; This should be bound to the current source file being processed. - #:*current-source-file* - ;; A generic method called for each compiled lisp source file. #:compile-source - ;; Generic processing for files. - #:process-file - ;; Generics for specific commands. - #:init-action - #:finish-action - #:load-file - ;; bazel-lisp warning handler. - #:handle-warning - ;; Post entry generic handler for each command. - #:execute-command - ;; Action model accessors - #:*action* - #:action - #:action-command - #:action-args - #:action-output-files - #:action-processing-sources-p - #:action-save-runtime-options-p - #:action-main-function - #:action-warning-handlers - #:action-compilation-mode - #:action-source-files - #:action-find-output-file - #:action-failures - #:action-deferred-warnings + #:load-file ; for interactive use #:add-features #:add-feature)) (in-package #:bazel.main) -;;; -;;; Basic Utilities -;;; - -(defstruct file - "Represents a file with name and contents." - (name nil :type string) - (contents nil :type (simple-array octet))) - -(defmethod cl:print-object ((file file) stream) - "Prints the file object as an unreadable object." - (print-unreadable-object (file stream :type t) - (format stream "~S (~D)" (file-name file) (length (file-contents file))))) - -(defun get-file-contents (file-name) - "Read contents of a file with FILE-NAME and return them as an array of octets." - (with-open-file (stream file-name :element-type 'octet) - (let* ((length (file-length stream)) - (contents (make-array (the fixnum length) :element-type 'octet))) - (assert (= length (read-sequence contents stream))) ; NOLINT - contents))) - -(defun get-file (file-name) - "Returns a file object with contents for FILE-NAME." - (make-file - :name file-name - :contents (get-file-contents file-name))) - -(defun stem-file-name (name) - "Removes the type of file from the end of its NAME." - (declare (string name)) - (let ((type (pathname-type name))) - (if type - (subseq name 0 (- (length name) (length (the string type)) 1)) - name))) - ;;; ;;; BUILD-action model ;;; @@ -127,8 +58,6 @@ ;; Flag indicating that the final binary should have its runtime options burned. ;; Value T will prevent such target binary from interpreting those options from the command line. (save-runtime-options-p nil :type boolean) - ;; Indicates that source forms positions should be recorded. - (record-path-location-p nil :type boolean) ;; The main function for a binary. (main-function nil :type (or null symbol string)) ;; Whether block compilation is enabled. @@ -142,26 +71,21 @@ (compilation-mode nil :type compilation-mode) ;; A list of failures. (failures nil :type list) - ;; A list of deferred-warnings. - (deferred-warnings nil :type list) ;; A count of muffled infos. (muffled-infos-count 0 :type fixnum) ;; A count of muffled warnings. - (muffled-warnings-count 0 :type fixnum) - ;; Readtable used for this action. - (readtable *readtable* :type readtable)) + (muffled-warnings-count 0 :type fixnum)) (defmethod cl:print-object ((action action) stream) "Prints the FASL file object as an unreadable object." (print-unreadable-object (action stream :type t) (format stream ":command ~S :outputs ~D~@[ :main ~S~] :compilation-mode ~S ~ - :failures ~D :deferred ~D :muffled ~D :infos ~D" + :failures ~D :muffled ~D :infos ~D" (action-command action) (length (action-output-files action)) (action-main-function action) (action-compilation-mode action) (length (action-failures action)) - (length (action-deferred-warnings action)) (action-muffled-warnings-count action) (action-muffled-infos-count action)))) @@ -169,64 +93,6 @@ ;; All of the state of the current bazel-lisp BUILD action. ;; The action is shared among threads. (defvar *action* nil) -(declaim (type mutex *action-mutex*)) -(defvar *action-mutex* (make-mutex :name "bazel-lisp-action-mutex") - "Action mutex guards *action* global variable.") - -(defun print-action-full (&key - args - (action *action*) - (verbose *verbose*) - (stream *standard-output*)) - "Print the ACTION using VERBOSE mode to the output STREAM." - (declare (optimize (debug 3) (speed 0))) - (let* ((*verbose* verbose) - (args (copy-list (if action (action-args action) args))) - (deps (split (getf args :deps))) - (srcs (split (getf args :srcs))) - (specs (getf args :specs)) - (load (split (getf args :load))) - (outs (split (getf args :outs))) - (warnings (split (getf args :warning))) - (hashes (split (getf args :hashes))) - (bindir (getf args :bindir))) - (when (< verbose 2) - (when (> (length deps) 1) (remf args :deps)) - (when (> (length srcs) 1) (remf args :srcs)) - (when (> (length load) 1) (remf args :load))) - (when (< verbose 3) - (when (> (length warnings) 1) (remf args :warnings)) - (when (> (length hashes) 1) (remf args :hashes))) - - (verbose "Program name: ~A" (program-name)) - (vv "Command line: ~{'~A'~^ ~}" (command-line-arguments)) - (verbose "Current dir: ~A" *default-pathname-defaults*) - (verbose "Params:~{~&~3T~A: ~A~%~}" args) - #+sbcl - (vv "Environment:~{~%~3T~S~}~%" (sb-unix::posix-environ)) - (verbose "Action: ~A~%" action) - (flet ((strip-bindir (name) (if bindir (strip-prefix bindir name) name))) - (cond ((< verbose 2) - (verbose "Deps: ~A" (length deps)) - (verbose "Srcs: ~A" (length srcs)) - (verbose "Load: ~A" (length load))) - (t - (vv "Deps:~{~%~3T~A~}" (mapcar #'strip-bindir deps)) - (vv "Srcs:~{~%~3T~A~}" (mapcar #'strip-bindir srcs)) - (vv "Load:~{~%~3T~A~}" (mapcar #'strip-bindir load)))) - (verbose "Outs:~{~%~3T~A~}" (mapcar #'strip-bindir outs)) - (when (< verbose 3) - (verbose "Hashes: ~A" (length hashes)) - (verbose "Warnings: ~A" (length warnings)))) - (when (and (>= verbose 3) specs (probe-file specs)) - (verbose "Specs file: ~S contents" specs) - (with-open-file (in specs - :element-type 'character - :external-format :utf-8) - (loop :for line = (read-line in nil) - :while line - :do (write-string line stream) - (terpri stream)))))) ;; The current file being processed. (declaim (type (or null string) *current-source-file*)) @@ -236,36 +102,36 @@ "Contains the name of the currently processed file. Used by error reporting.") ;; The set of compiled sources with their md5 checksums. -;; TODO(czak): Rename source-file-hash. -(declaim (type hash-table *compiled-sources*)) -(defvar *compiled-sources* (make-hash-table :test #'equal) - "Stores compiled source names relative to google3 with the corresponding md5 hashes.") +;; Constructed on demand +(define-symbol-macro *compiled-sources* (get-or-make-md5sum-table)) +(defvar %namestring-to-md5sum nil) ; NOLINT +(defun get-or-make-md5sum-table () + "Construct hash-table from debug-infos" + (or %namestring-to-md5sum + #-sbcl (error "Implement") + #+sbcl + (let ((ht (make-hash-table :test 'equal))) + (dolist (c (sb-vm:list-allocated-objects + :all :type sb-vm:code-header-widetag) + (setf %namestring-to-md5sum ht)) + (when (typep (sb-kernel:%code-debug-info c) 'sb-c::debug-info) + (let* ((di (sb-kernel:%code-debug-info c)) + (src (sb-c::debug-info-source di))) + (unless (typep src 'sb-c::core-debug-source) + (let ((md5sum (getf (sb-c::debug-source-plist src) :md5sum))) + (when md5sum + (setf (gethash (sb-c::debug-source-namestring src) ht) + md5sum)))))))))) (defun action-add-failure (warning &optional (action *action*)) "Add a WARNING to the failures list of the ACTION." (verbose "Added failure: ~S '~A'" (type-of warning) warning) - (with-recursive-lock (*action-mutex*) - (pushnew (list *current-source-file* (type-of warning) warning) - (action-failures action) :test #'equalp))) - -(defun action-find-output-file (action type) - "Searches in the ACTION output files for a file ending with the string TYPE." - (declare (type action action) (string type)) - (find type (action-output-files action) :key #'pathname-type :test #'equalp)) - -(defun action-find-output-file-with-name (action name type) - "Searches in the ACTION output files for a file ending with - the string TYPE and starting with the string NAME." - (declare (type action action) (string name type)) - (find-if #'(lambda (pathname) - (and (string= (pathname-name pathname) name) - (string= (pathname-type pathname) type))) - (action-output-files action))) + (pushnew (list *current-source-file* (type-of warning) warning) + (action-failures action) :test #'equalp)) ;;; ;;; Functions dealing with compiler warnings and deferred warnings. ;;; This requires the bazel.warning package. -;;; TODO(czak): Add support for those into UIOP. ;;; (defun resolve-warning-handler (handler &key (fail-on-error t)) @@ -340,58 +206,10 @@ package context. This allows for the user to specify their own handlers as a str (vvv "Handler ~A => ~A" handler value) (case value ((nil) nil) - ((:show) (setf result :show)) ((:fail) (return :fail)) (t (when restart (return :muffle))))) finally (return result))) -(defun save-deferred-warnings (warning-file warnings) - "Saves the WARNINGS to the WARNING-FILE." - (declare (string warning-file) (list warnings)) - (verbose "Saving ~A warning~:P: ~S" (length warnings) warning-file) - (delete-read-only warning-file) - (with-open-file (out warning-file :direction :output :if-exists :supersede) - (with-standard-io-syntax - (format out "~@[(~{~S~^~%~})~]" warnings)))) - -(defun read-deferred-warnings (action warnings-file) - "Reads warnings from the WARNINGS-FILE and appends those to the ACTION deferred-warnings." - (with-open-file (in warnings-file) - (with-standard-io-syntax - (loop with count fixnum = 0 - for warnings = (read in nil :eof) - until (eq warnings :eof) do - (incf count (length (the list warnings))) - (setf (action-deferred-warnings action) - (union (action-deferred-warnings action) warnings :test #'equalp)) - finally - (message :info (if (plusp count) 1 3) - "Read ~D warning~:P from: ~A" count warnings-file))))) - -(defun resolve-deferred-warnings (warnings) - "Try to resolve deferred WARNINGS. Return a list of unresolved ones." - (declare (list warnings)) - (let ((length (length warnings))) - (message :info (if (plusp length) 1 2) "Resolving ~D deferred warning~:P" length)) - (loop for warning in warnings - for (src kind-of-warning data) = warning - for not-resolved - = (if (and (eq kind-of-warning :undefined-function) - (fboundp data)) - (cond ((inline-function-p data) - ;; Inline functions cannot be deferred. - `((,src :undefined-inline-function ,data))) - ((and (symbolp data) (macro-function data)) - `((,src :undefined-macro ,data))) - ((compiler-macro-function data) - `((,src :undefined-compiler-macro-function ,data))) - ((function-has-transforms-p data) - `((,src :undefined-function-transforms ,data)))) - (list warning)) - do - (message :info (if not-resolved 1 2) "~8T~S => ~:[~;not ~]resolved." warning not-resolved) - nconc not-resolved)) - (defun handle-warning (warning &optional (action *action*)) "Invoke the WARNING handlers and adds a failure to the ACTION failure list." (unless *current-source-file* (return-from handle-warning nil)) @@ -400,8 +218,6 @@ package context. This allows for the user to specify their own handlers as a str (ecase result (:ignore (bazel.log:vvv "IGNORE: ~S '~A'" (type-of warning) warning)) - (:show - (bazel.log:info "SHOW: ~S '~A'" (type-of warning) warning)) (:muffle (bazel.log:vv "MUFFLE: ~S '~A'" (type-of warning) warning) (if warning-p @@ -464,13 +280,6 @@ package context. This allows for the user to specify their own handlers as a str ;;; Bazel-Lisp specific utilities ;;; -(defun delete-doc-strings () - "Delete all the symbol doc strings." - (do-all-symbols (var) - (dolist (type '(function type structure variable setf method-combination compiler-macro)) - (when (documentation var type) - (setf (documentation var type) nil))))) - (declaim (type (or symbol function) *entry-point*)) (defvar *entry-point* nil) @@ -482,9 +291,6 @@ If LISP_MAIN is NIL or T it will call top-level REPL as well." (let ((entry-point *entry-point*) (LISP_MAIN (getenv "LISP_MAIN"))) - ;; Provided UIOP is loaded, apply its image restore protocol. - (funcall-named "UIOP:CALL-IMAGE-RESTORE-HOOK") - (when LISP_MAIN (unsetenv "LISP_MAIN") (handler-case @@ -503,34 +309,7 @@ If LISP_MAIN is NIL or T it will call top-level REPL as well." (funcall entry-point))) -(defun derive-entry-point (main) - "Returns NIL, SYMBOL, or FUNCTION based on the MAIN function specification." - (let* ((main-exp - (if (stringp main) - (with-standard-io-syntax - (read-from-string main)) - main))) - (typecase main-exp - (null nil) - (function main-exp) - (symbol - (unless (fboundp main-exp) - (fatal "~S is not a known function name." main-exp)) - main-exp) - (cons - (let ((fname (first main-exp))) - (cond ((or (not (symbolp fname)) - (macro-function fname) - (special-operator-p fname)) - (lambda () (eval main-exp))) - ((fboundp fname) - (lambda () (apply fname (rest main-exp)))) - (t - (fatal "~S is not a known function name." fname))))) - (t - (fatal "Cannot use ~S as an entry point." main-exp))))) - -(defun save-image (name main &key save-runtime-options precompile-generics remove-debug-info +(defun save-image (name main &key save-runtime-options precompile-generics executable) "Saves the image to a binary image named 'name'. Exits. Arguments: @@ -541,20 +320,23 @@ If LISP_MAIN is NIL or T it will call top-level REPL as well." This is usually permanent. PRECOMPILE-GENERICS - will precompile the generic functions before saving. EXECUTABLE - Whether to combine the launcher with the image to create an executable." - (let ((main-fn (derive-entry-point main))) + (let ((main-fn (or (if (stringp main) + (with-standard-io-syntax (read-from-string main)) + ;; what else could it be but a string? + main) + 'sb-impl::toplevel-init))) + (etypecase main-fn + (symbol + (unless (fboundp main-fn) + (fatal "~S is not a known function name." main-fn)))) (verbose "Saving binary to: ~S~@[ (old-main: ~S)~]~@[ (main: ~S)~]" name (unless (eq main-fn *entry-point*) *entry-point*) main-fn) (setf *entry-point* main-fn)) - (when remove-debug-info - (remove-extra-debug-info)) - ;; Provided UIOP is loaded, apply its image dump protocol. - (funcall-named "UIOP:CALL-IMAGE-DUMP-HOOK") ;; Set to a sane value. (in-package "COMMON-LISP-USER") - (dolist (candidate '("lisp/devtools/bazel/imagesave.lisp" - "third_party/lisp/bazel/imagesave.lisp")) - (when (probe-file candidate) - (load candidate :verbose nil :print nil) + (let ((script "third_party/lisp/bazel/imagesave.lisp")) + (when (probe-file script) + (load script :verbose nil :print nil) (funcall (intern "SAVE-AND-EXIT") name :toplevel #'restart-image @@ -573,7 +355,8 @@ If LISP_MAIN is NIL or T it will call top-level REPL as well." (destructuring-bind (spEed Debug saFety space Compilation-speed) (ecase optimization-mode ; E D F C (:load '(1 1 1 1 3)) - ((:fastbuild nil) '(1 2 3 1 1)) + ((:fastbuild nil) '(1 #+arm64 1 #-arm64 2 ; arm64 has compiler bugs in debug 2 + 3 1 1)) (:opt '(3 0 0 1 1)) (:dbg '(1 3 3 1 1))) @@ -590,39 +373,16 @@ If LISP_MAIN is NIL or T it will call top-level REPL as well." #+sbcl(sb-c::insert-array-bounds-checks 3))))) (defun to-feature (feature) - "Return a symbol feature derived from a FEATURE string or symbol. - -By default the string is read into the KEYWORD package. -If the feature string is package prefixed, the package -is instantiated unless already provided. - -If the feature parses as anything other than a symbol, -it will signal an error." - (typecase feature - (symbol feature) + "Intern FEATURE in the keyword package if a string, or return as-is if a symbol" + (etypecase feature + (symbol (the (not null) feature)) (string - (multiple-value-bind (value error) - (ignore-errors - (let ((*package* (find-package "KEYWORD"))) - (with-creating-find-package () - (values (read-from-string feature))))) - (cond ((and (symbolp value) value)) - (error - (bazel.log:fatal - "Could not parse ~S as a feature due to~% ~S: ~A~%" - feature (type-of error) error) - nil) - (t - (bazel.log:fatal "Cannot parse ~S as a feature." feature) - nil)))) - (t - (bazel.log:fatal "~S is not a feature." feature)))) + (assert (not (find #\: feature))) + (intern (string-upcase feature) "KEYWORD")))) (defun add-feature (feature) "Add a single string FEATURE to *features*." - (let ((feature (to-feature feature))) - (when feature - (pushnew feature *features*)))) + (pushnew (to-feature feature) *features*)) (defun add-features (string) "Add the features from the STRING first converting them into keywords." @@ -651,8 +411,7 @@ it will signal an error." fasl (action *action*) (load-mode (action-compilation-mode action)) - (muffle-warnings (not (action-processing-sources-p action))) - (readtable (action-readtable action))) + (muffle-warnings (not (action-processing-sources-p action)))) "Loads a file with NAME using action-compilation-mode. Checks for duplications and marks file as loaded. The warnings are muffled for dependencies. Arguments: @@ -660,39 +419,22 @@ it will signal an error." FASL - if non-nil, the FASL will be loaded in place of the Lisp file. ACTION - the current bazel action object, LOAD-MODE - the load mode used to load the file. - MUFFLE-WARNINGS - if true, as in the case of deps, no warnings will be printed. - READTABLE - is the readtable to be used while loading." + MUFFLE-WARNINGS - if true, as in the case of deps, no warnings will be printed." (declare (type (or string pathname) name) (type action action)) (unless load-mode (return-from load-file)) - (with-open-file (in (or fasl name)) - (unless (plusp (file-length in)) - (bazel.log:verbose "Not loading an empty file: ~S." name) - (return-from load-file))) (with-safe-io-syntax (handler-bind ((non-fatal-error #'handle-error)) (with-compilation-unit (:source-namestring name) (let* ((name (namestring name)) (*default-pathname-defaults* *default-pathname-defaults*) (*current-source-file* name) - (*readtable* (setup-readtable readtable)) (*action* action)) (set-optimization-mode load-mode) (cond (muffle-warnings (with-all-warnings-muffled - ;; TODO(czak): use bazel.warning:redefine-warning. - ;; For this we need to know the NOWARN info - ;; for each package. (handler-bind (((or bazel.warning:redefined-function - bazel.warning:redefined-macro - ;; bazel.warning:changed-ftype-proclamation - bazel.warning:conflicting-ftype-declaration - ;; TODO(czak): someone fix cl-pb. - ;; bazel.warning:redefined-generic - ;; bazel.warning:redefined-method - bazel.warning:redefined-package - bazel.warning:inline-used-before-definition - bazel.warning:compiler-macro-after-function-use) + bazel.warning:redefined-macro) #'handle-warning)) (load (or fasl name) :external-format :utf-8)))) (t @@ -703,28 +445,41 @@ it will signal an error." ;;; (defun %compile-sources (srcs output-file &key - save-locations - (readtable (copy-readtable)) block-compile) "Compiles the list of SRCS files into the OUTPUT-FILE. A corresponding FASL will be created. Returns (values FASL WARNINGS-P FAILURES-P). Parameters: - SAVE-LOCATIONS when non-nil will save the path locations to the FASL file as well. - READTABLE is the readtable to be used for compiling the SRC file. BLOCK-COMPILE is whether to block compile, and can be either T or :SPECIFIED. ENTRY-POINTS is a list of entry points which are used when block-compiling." - (verbose "~{~A ~} => ~S (~A)" srcs (namestring output-file) *default-pathname-defaults*) - (ensure-directories-exist output-file) (multiple-value-bind (fasl warnings-p failures-p) - (with-compilation-unit (:source-namestring (car srcs)) + (with-compilation-unit (:source-plist `(:md5sum ,(md5sum-file (car srcs))) + :source-namestring (car srcs)) (with-safe-io-syntax - (let ((output-file (merge-pathnames output-file)) - (*default-pathname-defaults* *default-pathname-defaults*) - (*readtable* (setup-readtable readtable))) - (delete-read-only output-file) - (compile-files srcs :output-file output-file - :external-format :utf-8 - :block-compile block-compile)))) + (let ((*default-pathname-defaults* *default-pathname-defaults*)) + (cond ((eq output-file :anonymous) + (assert (not (cdr srcs))) + (let ((compile-file-to-tempfile (find-symbol "COMPILE-FILE-TO-TEMPFILE" "SB-C"))) + (if compile-file-to-tempfile + (funcall compile-file-to-tempfile (car srcs) + :external-format :utf-8 + :block-compile block-compile) + ;; Fallback for standard SBCL: compile to a generated temporary pathname + (let ((temp-file (sb-ext:parse-native-namestring + (format nil "/tmp/sbcl-temp-~A.fasl" + (sb-unix:unix-getpid))))) + (compile-file (car srcs) :output-file temp-file + :external-format :utf-8 + :block-compile block-compile) + temp-file)))) + (t + (verbose "~{~A ~} => ~S (~A)" srcs (namestring output-file) + *default-pathname-defaults*) + (ensure-directories-exist output-file) + (let ((output-file (merge-pathnames output-file))) + (ignore-errors (delete-file output-file)) + (compile-files srcs :output-file output-file + :external-format :utf-8 + :block-compile block-compile))))))) (unless (and warnings-p failures-p) (vv "Files ~A compiled without warnings." srcs)) (when warnings-p @@ -732,138 +487,99 @@ it will signal an error." (with-simple-restart (continue "Ignore compilation failure for ~A and continue." srcs) (when failures-p (fatal "Files ~A failed to compile." srcs))) - (when save-locations - (mapc #'(lambda (src) - (funcall-named* "BAZEL.PATH:SAVE-LOCATIONS" - src output-file :readtable readtable)) - srcs)) (values fasl warnings-p failures-p))) -(defgeneric compile-source (src output-file &key save-locations - readtable - block-compile) - (:documentation "Compile the SRC file into the FASL OUTPUT-FILE. - SAVE-LOCATIONS unless nil causes the compilation process to record - line and column numbers for all forms read from SRC. - READTABLE is the readtable to be used for compilation. - BLOCK-COMPILE is whether to block compile, and can be either T or :SPECIFIED.")) - -(defmethod compile-source (src output-file - &rest key-args &key - save-locations - (readtable (copy-readtable)) - block-compile) +(defun compile-source (src output-file &rest key-args &key block-compile) "Compiles the SRC file into the OUTPUT-FILE. A corresponding FASL will be created. Returns (values FASL WARNINGS-P FAILURES-P). Parameters: - SAVE-LOCATIONS when non-nil will save the path locations to the FASL file as well. - READTABLE is the readtable to be used for compiling the SRC file. - BLOCK-COMPILE is whether to block compile, and can be either T or :SPECIFIED. - ENTRY-POINTS is a list of entry points which are used when block-compiling." - (declare (ignore save-locations readtable block-compile)) + BLOCK-COMPILE is whether to block compile, and can be either T or :SPECIFIED." + (declare (ignore block-compile)) (apply #'%compile-sources (list src) output-file key-args)) -(defun write-file-hash (src hash-file) - "Compute the hash of the SRC file and write it to the HASH-FILE." - (assert (equalp (pathname-type hash-file) "hash")) ; NOLINT - (let ((md5sum (md5sum-file src))) - (delete-read-only hash-file) - (with-open-file (out hash-file :direction :output :if-exists :supersede :element-type 'octet) - (write-stringz src out) - (write-sequence md5sum out)) - (vv "Saved MD5 sum ~S to ~S." md5sum hash-file))) - -(defun defer-undefined-warning (warning &optional (action *action*)) - "If the WARNING is an undefined function warning, add it to ACTION's deferred warnings." - (multiple-value-bind (undefined function) (bazel.warning:undefined-function-p warning) - (when undefined - (verbose "Added deferred warning: ~S '~A'" (type-of warning) warning) - (pushnew `(,*current-source-file* :undefined-function ,function) - (action-deferred-warnings action) :test #'equalp) - t))) +(defun defer-undefined-warning (warning) + "Return true if WARNING is an undefined function warning and is therefore ignorable." + ;; Separately compiled units see hundreds if not thousands of this kind of warning. + ;; Missing functions become relevant (and are detected) only when producing a core file. + (values (bazel.warning:undefined-function-p warning))) ;;; ;;; File handlers ;;; -(defgeneric process-file (action file type) - (:documentation "Process each input FILE of TYPE for this BUILD ACTION.")) - -(defmethod process-file ((action action) (file string) type) - "Skips the given file for which there is no other handler." - ;; Maybe this should error instead of skip, but it's possible for files to be included in the - ;; build command-line just to forward those to things analyzing the compilation with extra - ;; actions (i.e. .meta files forwarded to the Kythe indexer): - ;; https://docs.bazel.build/versions/master/be/extra-actions.html - (verbose "File skipped: ~S [~A]" file type)) - -(defmethod process-file ((action action) (file string) (type (eql :lisp))) - "Process a file with the .lisp or .lsp extensions. Loads file if not loaded, yet." - (unless (and (action-processing-sources-p action) - (eq (action-command action) :compile)) - (load-file file :action action :load-mode :load))) - -(defmethod process-file ((action action) (file string) (type (eql :lsp))) - "Alias for function processing .lisp files." - (process-file action file :lisp)) - -(defmethod process-file ((action action) (file string) (type (eql :fasl))) - "Loads a FASL file." - (prog1 (load-file file :fasl file :action action - :load-mode (action-compilation-mode action)) - ;; Sort some heap after every FASL. - #+sbcl (sb-ext:gc))) - -(defmethod process-file ((action action) (file string) (type (eql :warnings))) - "Loads a deferred warnings file. Deferred warnings are only checked in a binary (final) target." - (cond ((member (action-command action) '(:core :binary)) - ;; For binary target read the deferred warnings here so those can be checked - ;; when the action is finalized later. - (read-deferred-warnings action file)))) - -(defmethod process-file ((action action) (file string) (type (eql :hash))) - "Loads an MD5 hash file." - (with-open-file (in file :element-type 'octet) - ;; NAMESTRING canonicalizes to base-char (in SBCL at least), and furthermore - ;; returns a shareable string memoized on the corresponding pathname object. - (let ((src (namestring (read-stringz in))) - (md5 (make-array 16 :element-type 'octet))) - (assert (= 16 (read-sequence md5 in))) ; NOLINT - (setf (gethash src *compiled-sources*) md5)))) - -(defun process-file* (file &optional (action *action*)) - "Sets the environment before processing the file." +(defun process-file (file &aux (action *action*) (type (pathname-type file))) + "Process FILE" (let ((*current-source-file* file)) (vvv "~:[dep~;src~]: ~S" (action-processing-sources-p action) file) - (process-file action file (to-keyword (pathname-type file))))) - -(defun process-dependencies (deps) - "Iterates through the DEPS dependencies and invokes process-file on the DEPS." + (cond + ((or (string= type "lisp") (string= type "lsp")) + (unless (and (action-processing-sources-p action) + (eq (action-command action) :compile)) + (load-file file :action action :load-mode :load))) + ((string= type "fasl") + (load-file file :fasl file :action action + :load-mode (action-compilation-mode action))) + (t + ;; Maybe this should error instead of skip, but it's possible for files to be included in + ;; the build command-line just to forward those to things analyzing the compilation with + ;; extra actions (i.e. .meta files forwarded to the Kythe indexer): + ;; https://docs.bazel.build/versions/master/be/extra-actions.html + (verbose "File skipped: ~S [~A]" file type))))) + +(defun process-dependencies (deps collect-undefs) + "Iterates through the DEPS dependencies and invokes process-file on the DEPS. +if COLLECT-UNDEFS then return the unresolved function references" (verbose "Processing ~D dependencie~:P..." (length deps)) - (with-all-warnings-muffled - (with-compilation-unit () - (map () #'process-file* deps))) - (values)) + (let ((undefs (make-hash-table :test 'equal)) + (saved-hook sb-int:*setf-fdefinition-hook*)) + ;; Technically we only want to observe the calls to ENSURE-LINKAGE-INDEX that are + ;; a consequence of the FASL asking for such via APPLY-FASL-FIXUPS, but I can't + ;; see any way to hit this interceptor other than via the fasloader, except possibly + ;; a COMPILE action in a different thread. We can ignore that little glitch + ;; since there can't be another thread. + (let ((ensure-linkage-index (find-symbol "ENSURE-LINKAGE-INDEX" "SB-INT")) + (encapsulate (find-symbol "ENCAPSULATE" "SB-INT"))) + (when (and collect-undefs ensure-linkage-index encapsulate) + #+x86-64 + (funcall encapsulate ensure-linkage-index 'intercept + (lambda (realfun fname &optional quiet) + (when (and (not quiet) + (boundp 'sb-fasl::*current-fasl-group*)) + (cond ((and (fboundp fname) + ;; If FNAME is FBOUNDP to a function that is not inlineable, + ;; there's nothing further to do with it. + (not (inline-function-p fname)) + (or (listp fname) + (not (macro-function fname))))) + (t + ;; Record each source file that referenced the potentially-undefined name + (let ((source-file (sb-fasl::fasl-group-header-label + sb-fasl::*current-fasl-group*))) + (pushnew source-file (gethash fname undefs)))))) + (funcall realfun fname quiet))))))) + (unwind-protect + (with-all-warnings-muffled + (when collect-undefs + (push (lambda (fname defn) + (declare (ignore defn)) + (unless (inline-function-p fname) + (remhash fname undefs))) + sb-int:*setf-fdefinition-hook*)) + (with-compilation-unit () + (map nil #'process-file deps))) + (untrace) + (when collect-undefs + (setf sb-int:*setf-fdefinition-hook* saved-hook) + #+x86-64 + (sb-int:unencapsulate 'sb-int:ensure-linkage-index 'intercept))) + undefs)) ;;; ;;; Command handlers ;;; -(defgeneric execute-command (command &rest arguments &key &allow-other-keys) - (:documentation "Executes a COMMAND with the command line ARGUMENTS.")) - -(defgeneric init-action (action command) - (:documentation "Initializes the action based on the command") - (:method ((action action) command) #| noop |#)) - -(defgeneric finish-action (action command) - (:documentation "Given a finished BUILD action execute the final command.")) - (defun check-and-save-image (action command) "Save the binary from this image." - (nconcf (action-failures action) - (resolve-deferred-warnings - (shiftf (action-deferred-warnings action) nil))) (check-failures action) (check-features) @@ -871,45 +587,33 @@ it will signal an error." ;; Save image. Exit. (save-image (first (action-output-files action)) (action-main-function action) - :remove-debug-info (eq (action-compilation-mode action) :opt) :save-runtime-options (action-save-runtime-options-p action) :precompile-generics (action-precompile-generics-p action) :executable (eq command :binary))) -(defmethod finish-action ((action action) (command (eql :binary))) - (check-and-save-image action command)) -(defmethod finish-action ((action action) (command (eql :core))) - (check-and-save-image action command)) - -(defmethod finish-action ((action action) (command (eql :compile))) - "Compiles the last source file." - (let* ((srcs (action-source-files action)) - ;; Currently SBCL is not binding *compile-file-pathname* when raising undefined-function. - ;; So handle this in at least the one-file case. - (*current-source-file* - (unless (rest srcs) - (first srcs)))) - (%compile-sources srcs - (action-find-output-file action "fasl") - :save-locations (action-record-path-location-p action) +(defun finish-action (action command) "Finish ACTION + COMMAND" + (ecase command + ((:binary :core) ; executable core, nonexecutable core respectively + (check-and-save-image action command)) + (:compile ; "finishing" a compilation means calling COMPILE-FILE + ;; Currently SBCL is not binding *compile-file-pathname* when raising undefined-function. + ;; So handle this in at least the one-file case. + (let* ((srcs (action-source-files action)) + (out (first (action-output-files action))) + (*current-source-file* + (unless (rest srcs) + (first srcs)))) + (assert (string= (pathname-type out) "fasl")) + (%compile-sources srcs out :block-compile (if (and (action-block-compile-p action) (action-block-compile-specified-only action)) :specified - (action-block-compile-p action)) - :readtable (action-readtable action)) - (mapc #'(lambda (source-file) - (write-file-hash source-file - (action-find-output-file-with-name - action (pathname-name source-file) "hash"))) - (action-source-files action)) - (check-failures action) - (save-deferred-warnings - (action-find-output-file action "warnings") - (action-deferred-warnings action)))) + (action-block-compile-p action))) + (check-failures action))))) (defun parse-specs (specs) - "Parse the SPECS file and return values for SRCS, DEPS, LOAD, WARNINGS, and HASHES." - (let (srcs deps load warnings hashes) + "Parse the SPECS file and return values for SRCS, DEPS, LOAD." + (let (srcs deps load) (with-open-file (in specs :direction :input :element-type 'character) (loop for spec = (read in nil in) until (eq spec in) @@ -917,10 +621,21 @@ it will signal an error." (ecase (first spec) (:srcs (setf srcs (rest spec))) (:deps (setf deps (rest spec))) - (:load (setf load (rest spec))) - (:warnings (setf warnings (rest spec))) - (:hashes (setf hashes (rest spec)))))) - (values srcs deps load warnings hashes))) + (:load (setf load (rest spec)))))) + (values srcs deps load))) + +(defun coverage-exclude-p (src) + "Return T if SRC should never be coverage-instrumented" + (let ((dir (pathname-directory src))) + (when (or (eql (mismatch src "third_party/lisp/") 17) + ;; Don't instrument generated sources + ;; (:relative "bazel-out" ignore_this {genfiles|bin}) + ;; where ignore_this is probably "k8-opt" but doesn't matter. + (and (eq (first dir) :relative) + (string= (second dir) "bazel-out") + (stringp (fourth dir)) + (find (fourth dir) '("bin" "genfiles") :test 'string=))) + t))) ;;; ;;; Main Processing Loop @@ -928,7 +643,6 @@ it will signal an error." (defun process (command &rest args &key deps load srcs outs bindir - warnings hashes specs (compilation-mode :fastbuild) block-compile @@ -938,8 +652,7 @@ it will signal an error." precompile-generics save-runtime-options coverage - verbose - interactive) + verbose) "Main processing function for bazel.main. The keyword arguments of this function are flags for the compilation image. Arguments: @@ -950,8 +663,6 @@ the compilation image. SRCS - sources for a binary core or for compilation, OUTS - the output files, BINDIR - the directory for the output files (for debug), - WARNINGS - is a list of files that contain deferred warnings, - HASHES - is a list of files with defined source hashes, COMPILATION-MODE - from bazel -c BLOCK-COMPILE - Whether to enable block compilation. BLOCK-COMPILE-SPECIFIED-ONLY - Whether to only combine top-level-forms into a block within @@ -964,17 +675,14 @@ the compilation image. PRECOMPILE-GENERICS - if non-nil, precompile-generics before saving core, SAVE-RUNTIME-OPTIONS - will save the runtime options for the C runtime. COVERAGE - if the results should be instrumented with coverage information. - VERBOSE - Verbosity level from 0 to 3. - INTERACTIVE - Whether to enable interactive debugging." - (declare (ignore interactive verbose)) ; handled in execute-command - (multiple-value-setq (srcs deps load warnings hashes) + VERBOSE - Verbosity level from 0 to 3." + (declare (ignore verbose)) ; handled in execute-command + (multiple-value-setq (srcs deps load) (if specs (parse-specs specs) (values (split srcs) (split deps) - (split load) - (split warnings) - (split hashes)))) + (split load)))) (let* ((command (to-keyword command)) (outs (split outs)) @@ -990,7 +698,6 @@ the compilation image. :force-compilation-p force :precompile-generics-p precompile-generics :save-runtime-options-p save-runtime-options - :record-path-location-p coverage :block-compile-p block-compile :block-compile-specified-only block-compile-specified-only)) @@ -1004,58 +711,76 @@ the compilation image. ;; Rebind globally. (setf *action* action) - (when (>= *verbose* 1) - (print-action-full)) - (unless outs (fatal "Missing output file. Called with:~%~{~12T~A: ~A~%~}" args)) - (init-action action command) (add-features features) (add-default-features compilation-mode) (mapc (lambda (nowarn) (action-add-nowarn nowarn action)) (split nowarn)) - ;; Compiler-note failures must precede uninteresting-condition. - (action-add-nowarn #'bazel.warning:fail-inline-expansion-limit) - (action-add-nowarn #'bazel.warning:fail-stack-allocate-notes) ;; All notes are discarded here. (action-add-nowarn 'bazel.warning:uninteresting-condition) (action-add-nowarn #'defer-undefined-warning) #+sbcl - (when coverage + (when (and coverage (not (and (sb-int:singleton-p srcs) + (coverage-exclude-p (car srcs))))) (bazel.log:verbose "Turning on coverage-instrumented code generation.") (proclaim '(optimize (sb-c:store-coverage-data 3)))) - (process-dependencies deps) - ;; Load in any source hash information files. - (mapc #'process-file* hashes) + ;; :core is a nonexecutable core, :binary prepends the SBCL C runtime + (let ((undefs (process-dependencies deps (case command ((:binary :core) t))))) + (when (and undefs (plusp (hash-table-count undefs))) + ;; We want to detect these situations: + ;; - name got defined but is a macro + ;; - name got defined but is an inline function + ;; - name was never defined + ;; A few things are tricky about getting the errors entirely right, + ;; and we can't afford false positives because they will spuriously break + ;; the build. Better to have false negatives. + ;; - Inline functions with a locally NOTINLINE should reference the global name. + ;; - Reference to #'NAME is also usually ok. + ;; - Compiler-macros may decline to expand. + (let ((pivot (make-hash-table))) ; pathnames can be compared by EQ + ;; Take the mapping from function name to list of pathnames mentioning it and + ;; pivot it to a mapping from source file to list of functions it refers to. + (maphash (lambda (fname pathnames) + (when t #+nil (or (not (fboundp fname)) + (and (symbolp fname) (macro-function fname))) + (dolist (pathname pathnames) + (pushnew fname (gethash pathname pivot))))) + undefs) + (maphash (lambda (pathname fnames) + (message :error 0 "~A has linkage errors:~:{~% ~S - missing ~A~}" + (namestring pathname) + (mapcar (lambda (fname) + (list fname + (cond ((and (symbolp fname) + (macro-function fname)) + "macro definition") + ((inline-function-p fname) + "inline definition") + (t + "definition")))) + fnames))) + pivot) + (fatal "Build failed")))) (handler-bind ((condition #'handle-warning) (non-fatal-error #'handle-error)) (verbose "Loading ~D source file~:P..." (length load)) - (mapc #'process-file* load) + (mapc #'process-file load) ;; Switch to source file processing. (setf (action-processing-sources-p action) t) (verbose "Processing ~D source file~:P..." (length srcs)) - (mapc #'process-file* srcs) - - (verbose "Processing ~D deferred warning file~:P..." (length warnings)) - (mapc #'process-file* warnings) + (mapc #'process-file srcs) (verbose "Finalizing the ~A action..." command) (set-optimization-mode (action-compilation-mode action)) (finish-action action command)))) -(defmethod execute-command ((command (eql :compile)) &rest args) - (apply #'process command args)) -(defmethod execute-command ((command (eql :binary)) &rest args) - (apply #'process command args)) -(defmethod execute-command ((command (eql :core)) &rest args) - (apply #'process command args)) - ;;; ;;; Main entry point ;;; @@ -1083,33 +808,43 @@ the compilation image. "Parses the command-line and returns ARGS as list of keyword value pairs." (list* (to-keyword (first args)) (parse-rest-command-args (rest args)))) -(defmethod execute-command :around (command - &rest args - &key force verbose interactive - &allow-other-keys) +(defun execute-command (command &rest args &key verbose &allow-other-keys) ; NOLINT ;; Process some meta-level options. (when verbose (setf *verbose* (read-from-string verbose))) - (set-interactive-mode interactive) (verbose "Program name: ~A" (program-name)) (vv "Command line: ~{'~A'~^ ~}" (command-line-arguments)) (verbose "Current dir: ~A" *default-pathname-defaults*) + ;; core saving seems extremely shaky as of late, failing in either of the follows ways: + ;; + ;; 1) SB-SYS:MEMORY-FAULT-ERROR: Unhandled memory fault at #x59. while executing: CORE + ;; 2) pre-GC failure + ;; Ptr 0x1200c312c7 @ b8009e6020 (lispobj b8009e600f,pg-1,h=70e0cb5835) sees junk + ;; fatal error encountered in SBCL pid 7999 tid 7999: + ;; Verify failed: 1 errors + ;; 3: fp=0x7f5d3ea07590 pc=0x55db1677ec64 Foreign function (null) + ;; 4: fp=0x7f5d3ea07620 pc=0x55db1675ccef Foreign function hexdump_and_verify_heap + ;; 5: fp=0x7f5d3ea076c0 pc=0x55db1677c8bf Foreign function collect_garbage + ;; 6: fp=0x7f5d3ea07730 pc=0x55db1674e78c Foreign function gc_and_save + ;; + ;; Maybe we can get a little more information by enabling GC debugging here. + (when (member command '(:binary :core)) + (setf (sb-alien:extern-alien "pre_verify_gen_0" sb-alien:int) 0) + (setf (sb-alien:extern-alien "verify_gens" sb-alien:char) 0)) + (handler-bind ((error (lambda (e) (format *error-output* "~&~S: ~A while executing: ~A~%" (type-of e) e command) - (print-action-full - :args args :stream *error-output*) (unless verbose (exit 1))))) - (with-continue-on-error (:when force) - (call-next-method)))) - -(defmethod execute-command :after (command &rest ignore) - (declare (ignore ignore)) - (verbose "BAZEL ~A finished" command)) + (prog1 (apply #'process command args) + (verbose "BAZEL ~A finished" command)))) (defun main () "Main entry point." + (when (zerop (sb-alien:alien-funcall + (sb-alien:extern-alien "isatty" (function sb-alien:int sb-alien:int)) 0)) + (sb-ext:disable-debugger)) (apply #'execute-command (parse-command-args (command-line-arguments)))) diff --git a/mangler.lisp b/mangler.lisp new file mode 100644 index 0000000..0a209ae --- /dev/null +++ b/mangler.lisp @@ -0,0 +1,39 @@ +;; Exercise C++ name mangler + +(defparameter *testcases* + ;; + ;; Each test case is (expectation name-parts . signature) + ;; EXPECTATION is what c++filt should print when given the mangled test case. + ;; NAME-PARTS represent a possibly-namespace-qualified C++ name using an S-expression. + ;; SIGNATURE comprises the argument types that become part of the mangled name. + ;; + '(("do_math(int, long, unsigned long, double)" ; some basics + "do_math" + integer long unsigned-long double) + + ("my_namespace::inner_namespace::foofun(int, void*, char**)" ; namespace + ("my_namespace" "inner_namespace" "foofun") + integer (* void) (* * character)) + + ("base_logging::SetLogFilenameExtension(char const*)" ; const modifier + ("base_logging" "SetLogFilenameExtension") + (* const character)) + + ("Process::HandleSignal(int, siginfo_t*)" ; opaque type + ("Process" "HandleSignal") + integer (* "siginfo_t")) + + ("InitSomething(char const*, int*, char***, bool)" + "InitSomething" + (* const character) (* integer) (* * * character) boolean)) + "Tests") + +(defun main () + (dolist (test *testcases*) + (destructuring-bind (expectation name-parts . args) test + (let* ((mangled (bazel.sbcl:c++-mangle name-parts args)) + (demangler + (sb-ext:run-program "c++filt" (list mangled) :output :stream :search t)) + (demangled (read-line (process-output demangler)))) + (process-close demangler) + (assert (string= demangled expectation)))))) diff --git a/provider.bzl b/provider.bzl index 8238be2..3109d6f 100644 --- a/provider.bzl +++ b/provider.bzl @@ -11,11 +11,6 @@ LispInfo = provider( fields = { "fasls": "Depset of FASLs for transitive dependencies", "srcs": "Depset of transitive sources", - "hashes": "Depset of md5 hash files for transitive sources", - "warnings": ( - "Depset of files of warnings checked at link time (FASL load) " + - "for transitive sources" - ), "features": "Depset of transitive declared Lisp features", "compile_data": ( "Depset of files from transitive compile_data, made available " + @@ -67,8 +62,6 @@ def collect_lisp_info(deps = [], cdeps = [], build_image = None, features = [], transitive = [li.srcs for li in lisp_infos], order = "postorder", ), - hashes = depset(transitive = [li.hashes for li in lisp_infos]), - warnings = depset(transitive = [li.warnings for li in lisp_infos]), features = depset( features, transitive = [li.features for li in lisp_infos], @@ -80,23 +73,17 @@ def collect_lisp_info(deps = [], cdeps = [], build_image = None, features = [], def extend_lisp_info( base, fasls = [], - srcs = [], - hashes = [], - warnings = []): + srcs = []): """Extends a LispInfo with compilation inputs and outputs. Args: base: The base LispInfo provider to be extended. fasls: FASLs generated for this target. srcs: This target's Lisp sources. - hashes: Hash files for each file in srcs. - warnings: Warnings files for each file in srcs. """ return LispInfo( fasls = depset(fasls, transitive = [base.fasls], order = "postorder"), srcs = depset(srcs, transitive = [base.srcs], order = "postorder"), - hashes = depset(hashes, transitive = [base.hashes]), - warnings = depset(warnings, transitive = [base.warnings]), features = base.features, compile_data = base.compile_data, cc_info = base.cc_info, @@ -113,10 +100,6 @@ def print_provider(p): print("FASLs: %s" % [f.short_path for f in p.fasls.to_list()]) if p.srcs: print("Srcs: %s" % [s.short_path for s in p.srcs.to_list()]) - if p.hashes: - print("Hashes: %s" % [h.short_path for h in p.hashes.to_list()]) - if p.warnings: - print("Warnings: %s" % [w.short_path for w in p.warnings.to_list()]) if p.features: print("Features: %s" % p.features.to_list()) if p.compile_data: diff --git a/repositories.bzl b/repositories.bzl index bf66c45..0cff3ad 100644 --- a/repositories.bzl +++ b/repositories.bzl @@ -9,6 +9,10 @@ load( "git_repository", "new_git_repository", ) +load( + "@bazel_tools//tools/build_defs/repo:http.bzl", + "http_archive", +) def _include_if_not_defined(repo_rule, name, **kwargs): if not native.existing_rule(name): @@ -35,11 +39,18 @@ def bazelisp_repositories(): ) _include_if_not_defined( - git_repository, + http_archive, name = "rules_cc", - remote = "https://github.com/bazelbuild/rules_cc.git", - commit = "b1c40e1de81913a3c40e5948f78719c28152486d", - shallow_since = "1605101351 -0800", + sha256 = "abc605dd850f813bb37004b77db20106a19311a96b2da1c92b789da529d28fe1", + strip_prefix = "rules_cc-0.0.17", + urls = ["https://github.com/bazelbuild/rules_cc/releases/download/0.0.17/rules_cc-0.0.17.tar.gz"], + ) + + _include_if_not_defined( + git_repository, + name = "com_google_protobuf", + remote = "https://github.com/protocolbuffers/protobuf.git", + tag = "v21.7", ) # Installed SBCL in /usr/bin/sbcl and /usr/lib/sbcl/*. See BUILD.local_sbcl diff --git a/rule-tests/BUILD b/rule-tests/BUILD index 2a8df6f..2b9dc00 100644 --- a/rule-tests/BUILD +++ b/rule-tests/BUILD @@ -11,16 +11,11 @@ load( "create_empty_files", "fake_lisp_rule", "has_action_test", - "lisp_actions_dbg_test", - "lisp_actions_opt_test", "lisp_actions_test", - "lisp_deps_analysis_test", "lisp_instrumented_files_info_test", "lisp_providers_test", ) -package(default_applicable_licenses = ["//:license"]) - licenses(["notice"]) # This can create some of the files needed for these tests, but the tests for @@ -35,11 +30,8 @@ create_empty_files(names = [ "library-serial-2.lisp", "library-parallel-1.lisp", "library-parallel-2.lisp", - "library-multipass-1.lisp", - "library-multipass-2.lisp", "library-instrument-coverage.lisp", "binary-instrument-coverage.lisp", - "binary-custom-malloc.lisp", ]) fake_lisp_rule( @@ -167,20 +159,6 @@ lisp_providers_test( target_under_test = ":binary", ) -lisp_deps_analysis_test( - name = "binary-lisp-deps-test", - expected_content = ( - "feature: dep-feature\n" + - "feature: image-feature\n" + - "feature: binary-feature\n" + - "src: package/dep.lisp\n" + - "src: package/image.lisp\n" + - "src: package/binary.lisp\n" - ), - expected_out = "binary.deps", - target_under_test = ":binary", -) - lisp_instrumented_files_info_test( name = "binary-instrumented-files-test", instrumented_files = [ @@ -221,20 +199,6 @@ lisp_providers_test( target_under_test = ":test", ) -lisp_deps_analysis_test( - name = "test-lisp-deps-test", - expected_content = ( - "feature: dep-feature\n" + - "feature: image-feature\n" + - "feature: test-feature\n" + - "src: package/dep.lisp\n" + - "src: package/image.lisp\n" + - "src: package/test.lisp\n" - ), - expected_out = "test.deps", - target_under_test = ":test", -) - lisp_instrumented_files_info_test( name = "test-instrumented-files-test", instrumented_files = [ @@ -273,20 +237,6 @@ lisp_providers_test( target_under_test = ":library", ) -lisp_deps_analysis_test( - name = "library-lisp-deps-test", - expected_content = ( - "feature: dep-feature\n" + - "feature: image-feature\n" + - "feature: library-feature\n" + - "src: package/dep.lisp\n" + - "src: package/image.lisp\n" + - "src: package/library.lisp\n" - ), - expected_out = "library.deps", - target_under_test = ":library", -) - lisp_instrumented_files_info_test( name = "library-instrumented-files-test", instrumented_files = [ @@ -315,9 +265,7 @@ lisp_actions_test( 'binary-feature", ' + # The FASL is under the target name instead of src path if thre's # a single src. - '"--outs", "bin/package/binary.fasl ' + - "bin/package/binary~/package/binary.hash " + - 'bin/package/binary~/binary.warnings", ' + + '"--outs", "bin/package/binary.fasl", ' + '"--srcs", "package/binary.lisp", ' + '"--deps", "package/dep.lisp"]'), ("LispCore: " + @@ -329,10 +277,8 @@ lisp_actions_test( '"--main", "values", "--precompile-generics", ' + '"--save-runtime-options"]'), ("LispElfinate: " + - '["bash", "-c", "$1 split $2 $3", "", ' + - '"bin/elfinate.sar", ' + - '"bin/package/binary.core", ' + - '"bin/package/binary.s"]'), + '["bash", "-c", "bin/elfinate ' + + 'bin/package/binary.core bin/package/binary.s"]'), ], target_under_test = ":binary", ) @@ -346,9 +292,7 @@ lisp_actions_test( 'binary-feature", ' + # The FASL is under the target name instead of src path if thre's # a single src. - '"--outs", "bin/package/binary-allow-save-lisp.fasl ' + - "bin/package/binary-allow-save-lisp~/package/binary-allow-save-lisp.hash " + - 'bin/package/binary-allow-save-lisp~/binary-allow-save-lisp.warnings", ' + + '"--outs", "bin/package/binary-allow-save-lisp.fasl", ' + '"--srcs", "bin/package/binary-allow-save-lisp.lisp", ' + '"--deps", "package/dep.lisp"]'), ("LispCore: " + @@ -356,15 +300,8 @@ lisp_actions_test( '"--bindir", "bin", "--features", "dep-feature image-feature ' + 'binary-feature", ' + '"--specs", "bin/package/binary-allow-save-lisp.specs", ' + - '"--outs", "bin/package/binary-allow-save-lisp.core", ' + + '"--outs", "bin/package/binary-allow-save-lisp-core.o", ' + '"--main", "values", "--precompile-generics", "--save-runtime-options"]'), - ("LispElfinate: " + - '["bash", "-c", "$1 copy $2 $3 && nm -p $3 | ' + - 'awk \'{print $2\\";\\"}BEGIN{print \\"{\\"}END{print \\"};\\"}\' > $4", "", ' + - '"bin/elfinate.sar", ' + - '"bin/package/binary-allow-save-lisp.core", ' + - '"bin/package/binary-allow-save-lisp-core.o", ' + - '"bin/package/binary-allow-save-lisp-syms.lds"]'), ], target_under_test = ":binary-allow-save-lisp", ) @@ -378,41 +315,7 @@ lisp_actions_test( 'library-feature", ' + # The FASL is under the target name instead of src path if thre's # a single src. - '"--outs", "bin/package/library.fasl ' + - "bin/package/library~/package/library.hash " + - 'bin/package/library~/library.warnings", ' + - '"--srcs", "package/library.lisp", ' + - '"--deps", "package/dep.lisp"]'), - ], - target_under_test = ":library", -) - -lisp_actions_dbg_test( - name = "lisp-library-one-file-dbg-actions-test", - commands = [ - ("LispCompile: " + - '["bin/package/image", ' + DYNSPACE + ', "compile", "--compilation-mode", "dbg", ' + - '"--bindir", "bin", "--features", "dep-feature image-feature ' + - 'library-feature", ' + - '"--outs", "bin/package/library.fasl ' + - "bin/package/library~/package/library.hash " + - 'bin/package/library~/library.warnings", ' + - '"--srcs", "package/library.lisp", ' + - '"--deps", "package/dep.lisp"]'), - ], - target_under_test = ":library", -) - -lisp_actions_opt_test( - name = "lisp-library-one-file-opt-actions-test", - commands = [ - ("LispCompile: " + - '["bin/package/image", ' + DYNSPACE + ', "compile", "--compilation-mode", "opt", ' + - '"--bindir", "bin", "--features", "dep-feature image-feature ' + - 'library-feature", ' + - '"--outs", "bin/package/library.fasl ' + - "bin/package/library~/package/library.hash " + - 'bin/package/library~/library.warnings", ' + + '"--outs", "bin/package/library.fasl", ' + '"--srcs", "package/library.lisp", ' + '"--deps", "package/dep.lisp"]'), ], @@ -440,47 +343,19 @@ lisp_library( deps = [":dep"], ) -lisp_library( - name = "library-parallel", - testonly = 1, - srcs = [ - "library-parallel-1.lisp", - "library-parallel-2.lisp", - ], - image = ":image", - order = "parallel", - deps = [":dep"], -) - -lisp_library( - name = "library-multipass", - testonly = 1, - srcs = [ - "library-multipass-1.lisp", - "library-multipass-2.lisp", - ], - image = ":image", - order = "multipass", - deps = [":dep"], -) - lisp_actions_test( name = "lisp-library-serial-actions-test", commands = [ ("LispCompile: " + '["bin/package/image", ' + DYNSPACE + ', "compile", "--compilation-mode", "fastbuild", ' + '"--bindir", "bin", "--features", "dep-feature image-feature", "--outs", ' + - '"bin/package/library-serial~/package/library-serial-1.fasl ' + - "bin/package/library-serial~/package/library-serial-1.hash " + - 'bin/package/library-serial~/package/library-serial-1.warnings", ' + + '"bin/package/library-serial~/package/library-serial-1.fasl", ' + '"--srcs", "bin/package/library-serial-1.lisp", ' + '"--deps", "package/dep.lisp"]'), ("LispCompile: " + '["bin/package/image", ' + DYNSPACE + ', "compile", "--compilation-mode", "fastbuild", ' + '"--bindir", "bin", "--features", "dep-feature image-feature", ' + - '"--outs", "bin/package/library-serial~/package/library-serial-2.fasl ' + - "bin/package/library-serial~/package/library-serial-2.hash " + - 'bin/package/library-serial~/package/library-serial-2.warnings", ' + + '"--outs", "bin/package/library-serial~/package/library-serial-2.fasl", ' + '"--srcs", "bin/package/library-serial-2.lisp", ' + '"--deps", "package/dep.lisp", ' + # Serial, so for the second compile we load the first file. @@ -494,70 +369,6 @@ lisp_actions_test( target_under_test = ":library-serial", ) -lisp_actions_test( - name = "lisp-library-parallel-actions-test", - commands = [ - ("LispCompile: " + - '["bin/package/image", ' + DYNSPACE + ', "compile", "--compilation-mode", "fastbuild", ' + - '"--bindir", "bin", "--features", "dep-feature image-feature", "--outs", ' + - '"bin/package/library-parallel~/package/library-parallel-1.fasl ' + - "bin/package/library-parallel~/package/library-parallel-1.hash " + - 'bin/package/library-parallel~/package/library-parallel-1.warnings", ' + - '"--srcs", "bin/package/library-parallel-1.lisp", ' + - '"--deps", "package/dep.lisp"]'), - ("LispCompile: " + - '["bin/package/image", ' + DYNSPACE + ', "compile", "--compilation-mode", "fastbuild", ' + - '"--bindir", "bin", "--features", "dep-feature image-feature", ' + - '"--outs", "bin/package/library-parallel~/package/library-parallel-2.fasl ' + - "bin/package/library-parallel~/package/library-parallel-2.hash " + - 'bin/package/library-parallel~/package/library-parallel-2.warnings", ' + - '"--srcs", "bin/package/library-parallel-2.lisp", ' + - '"--deps", "package/dep.lisp"]'), - ("LispConcatFASLs: " + - '["bash", "-c", "cat ${@:2} > $1", "", ' + - '"bin/package/library-parallel.fasl", ' + - '"bin/package/library-parallel~/package/library-parallel-1.fasl", ' + - '"bin/package/library-parallel~/package/library-parallel-2.fasl"]'), - ], - target_under_test = ":library-parallel", -) - -lisp_actions_test( - name = "lisp-library-multipass-actions-test", - commands = [ - ("LispCompile: " + - '["bin/package/image", ' + DYNSPACE + ', "compile", "--compilation-mode", "fastbuild", ' + - '"--bindir", "bin", "--features", "dep-feature image-feature", "--outs", ' + - '"bin/package/library-multipass~/package/library-multipass-1.fasl ' + - "bin/package/library-multipass~/package/library-multipass-1.hash " + - 'bin/package/library-multipass~/package/library-multipass-1.warnings", ' + - '"--srcs", "bin/package/library-multipass-1.lisp", ' + - '"--deps", "package/dep.lisp", ' + - # Multipass both source files get loaded before compilation. - '"--load", "bin/package/library-multipass-1.lisp ' + - 'bin/package/library-multipass-2.lisp", ' + - # And some now-unavoidable warnings get suppressed. - '"--nowarn", "redefined-method redefined-function"]'), - ("LispCompile: " + - '["bin/package/image", ' + DYNSPACE + ', "compile", "--compilation-mode", "fastbuild", ' + - '"--bindir", "bin", "--features", "dep-feature image-feature", ' + - '"--outs", "bin/package/library-multipass~/package/library-multipass-2.fasl ' + - "bin/package/library-multipass~/package/library-multipass-2.hash " + - 'bin/package/library-multipass~/package/library-multipass-2.warnings", ' + - '"--srcs", "bin/package/library-multipass-2.lisp", ' + - '"--deps", "package/dep.lisp", ' + - '"--load", "bin/package/library-multipass-1.lisp ' + - 'bin/package/library-multipass-2.lisp", ' + - '"--nowarn", "redefined-method redefined-function"]'), - ("LispConcatFASLs: " + - '["bash", "-c", "cat ${@:2} > $1", "", ' + - '"bin/package/library-multipass.fasl", ' + - '"bin/package/library-multipass~/package/library-multipass-1.fasl", ' + - '"bin/package/library-multipass~/package/library-multipass-2.fasl"]'), - ], - target_under_test = ":library-multipass", -) - # Testing the effect of individual attrs: lisp_library( @@ -591,22 +402,6 @@ has_action_test( target_under_test = ":binary-instrument-coverage", ) -lisp_binary( - name = "binary-custom-malloc", - testonly = 1, - srcs = ["binary-custom-malloc.lisp"], - image = ":image", - main = "nil", - malloc = ":custom-malloc", -) - -has_action_test( - name = "binary-custom-malloc-test", - command_contains = "bin/package/_objs/custom-malloc/malloc.pic.o", - mnemonic = "CppLink", - target_under_test = ":binary-custom-malloc", -) - # Would be nice to have tests that demonstrate stamp is working correctly, but # I don't see where that shows up in the CppLink command-line, and the argv for # the CppLinkstampCompile action is not exposed to Starlark. diff --git a/rule-tests/tests.bzl b/rule-tests/tests.bzl index 00624a6..c3a5223 100644 --- a/rule-tests/tests.bzl +++ b/rule-tests/tests.bzl @@ -7,7 +7,10 @@ google3/lisp/devtools/bazel/macro-tests/. load("@bazel_skylib//lib:unittest.bzl", "analysistest", "asserts") load("//:provider.bzl", "LispInfo") -DYNSPACE = '"--dynamic-space-size", "5GB"' # value to expect for SBCL's --dynamic-space-size +# An argument pair that looks like --dynamic-space-size +# is changed to this constant value so we don't have to update the +# tests just because an invocation of SBCL wants more memory. +DYNSPACE = '"--dynamic-space-size", "nGB"' def create_empty_files(names): # buildozer: disable=unnamed-macro for name in names: @@ -37,10 +40,6 @@ def _fake_lisp_rule_impl(ctx): ), ) fake_src_file = ctx.file.src - fake_hash_file = ctx.actions.declare_file(ctx.label.name + ".hash") - - # This needs to be in the right format, but doesn't currently need to be corret. - ctx.actions.write(fake_hash_file, "{}\00{}".format(fake_src_file.path, "x" * 16)) # The executable will end up in runfiles by default, and that's enough for us to check # that's getting propagated. For the rest of these, generate some content that lets @@ -49,8 +48,6 @@ def _fake_lisp_rule_impl(ctx): LispInfo( fasls = depset([_empty_output(ctx, ".fasl")]), srcs = depset([fake_src_file]), - hashes = depset([fake_hash_file]), - warnings = depset([_empty_output(ctx, ".warnings")]), features = depset([ctx.label.name + "-feature"]), compile_data = depset([_empty_output(ctx, ".compile-data")]), cc_info = CcInfo(), @@ -66,7 +63,7 @@ fake_lisp_rule = rule( attrs = { "src": attr.label(allow_single_file = [".lisp"]), "_default_lisp_image": attr.label( - default = "//:image", + default = "//:test-image", executable = True, cfg = "target", allow_single_file = True, @@ -109,24 +106,21 @@ def _lisp_providers_test_impl(ctx): fasls = sorted([f.basename for f in lisp_info.fasls.to_list()]) asserts.equals(env, sorted(ctx.attr.fasls), fasls) - # LispInfo.srcs/hashes/warnings contains compilation outputs for each - # source file in the transitive dependencies. These are named based - # on the source file, i.e. foo.lisp parallels foo~.hash and foo~.warnings. + # LispInfo.srcs contains compilation outputs for each + # source file in the transitive dependencies. srcs = sorted([f.basename for f in lisp_info.srcs.to_list()]) - hashes = sorted([f.basename for f in lisp_info.hashes.to_list()]) - warnings = sorted([f.basename for f in lisp_info.warnings.to_list()]) expected_srcs = sorted(ctx.attr.src_outputs_for) expected_src_stems = [src.rsplit(".", 1)[0] for src in expected_srcs] - expected_hashes = [stem + ".hash" for stem in expected_src_stems] - expected_warnings = [stem + ".warnings" for stem in expected_src_stems] asserts.equals(env, expected_srcs, srcs) - asserts.equals(env, expected_hashes, hashes) - asserts.equals(env, expected_warnings, warnings) # LispInfo.features collects features (go/clhs/*features*) provided by # transitive dependencies. - lisp_features = sorted(lisp_info.features.to_list()) - asserts.equals(env, sorted(ctx.attr.lisp_features), lisp_features) + lisp_features = [ + x + for x in lisp_info.features.to_list() + if (x != "size-based-stdvector" and x != "copt-ndebug") + ] + asserts.equals(env, sorted(ctx.attr.lisp_features), sorted(lisp_features)) return analysistest.end(env) @@ -183,13 +177,30 @@ def _command(ctx, env, argv): argv[0] = "bash" return [_abbreviate_paths(ctx, env, arg) for arg in argv] +def _remove_size_based_stdvector(string): + strings = [x for x in string.split(" ") if x != "size-based-stdvector"] + return " ".join(strings) + def _lisp_actions_test_impl(ctx): """Asserts the command lines generated for run/run_shell actions for lisp_* are as expected.""" env = analysistest.begin(ctx) commands = [] for a in analysistest.target_actions(env): if a.argv and a.mnemonic.startswith("Lisp"): - commands.append("{}: {}".format(a.mnemonic, _command(ctx, env, a.argv))) + # argv is immutable. I looked for how to mutate it. + # YAQS says "A workaround is to make a copy of the list before appending to it." + # but then doesn't tell you how to copy. copy() would be the Python way + # however this isn't quite exactly Python and so copy doesn't work. + copy_of_argv = [] + copy_of_argv.extend(a.argv) + + # now mutate the copy + for i in range(len(copy_of_argv)): + if copy_of_argv[i] == "--dynamic-space-size": + copy_of_argv[1 + i] = "nGB" # dummy value + if copy_of_argv[i] == "--features": + copy_of_argv[1 + i] = _remove_size_based_stdvector(copy_of_argv[1 + i]) + commands.append("{}: {}".format(a.mnemonic, _command(ctx, env, copy_of_argv))) if len(ctx.attr.commands) == len(commands): for expected_command, actual_command in zip(ctx.attr.commands, commands): asserts.equals(env, expected_command, actual_command) @@ -264,32 +275,3 @@ has_action_test = analysistest.make( "//command_line_option:collect_code_coverage": "0", }, ) - -def _lisp_deps_analysis_test_impl(ctx): - """Asserts that the deps_manifest output group creates the expected manifest.""" - env = analysistest.begin(ctx) - target_under_test = analysistest.target_under_test(env) - - deps_manifest_output = target_under_test[OutputGroupInfo].deps_manifest.to_list() - asserts.equals(env, 1, len(deps_manifest_output)) - asserts.equals(env, ctx.attr.expected_out, deps_manifest_output[0].basename) - - actions = analysistest.target_actions(env) - generating_actions = [action for action in actions if action.outputs.to_list() == deps_manifest_output] - asserts.equals(env, 1, len(generating_actions)) - - content = _abbreviate_paths(ctx, env, generating_actions[0].content) - asserts.equals(env, ctx.attr.expected_content, content) - - return analysistest.end(env) - -lisp_deps_analysis_test = analysistest.make( - impl = _lisp_deps_analysis_test_impl, - attrs = { - "expected_out": attr.string(), - "expected_content": attr.string(), - }, - config_settings = { - "//:additional_dynamic_load_outputs": True, - }, -) diff --git a/rules.bzl b/rules.bzl index 80d9713..0b34e64 100644 --- a/rules.bzl +++ b/rules.bzl @@ -10,9 +10,33 @@ The three rules defined here are: lisp_library - The basic unit of compilation lisp_binary - Outputs an executable binary lisp_test - Outputs a binary that is run with the test command + +Usage example: + +load("//your/path/to/bazel:rules.bzl", "lisp_binary", "lisp_library", "lisp_test") + +lisp_library( + name = "foo", + srcs = ["foo.lisp"], + deps = ["//lisp/log"], +) + +lisp_binary( + name = "bar", + srcs = ["main.lisp"], + deps = [":foo"], +) + +lisp_test( + name = "foo-test", + srcs = ["foo-test.lisp"], + deps = [ + ":foo", + "//lisp/test", + ], +) """ -load("@bazel_skylib//rules:common_settings.bzl", "BuildSettingInfo") load("@rules_cc//cc:find_cc_toolchain.bzl", "find_cc_toolchain", "use_cc_toolchain") load( ":provider.bzl", @@ -21,21 +45,17 @@ load( "extend_lisp_info", ) -_BAZEL_LISP_IMAGE = "//:image" _BAZEL_LISP_IMAGE_MAIN = "bazel.main:main" _BAZEL_LISP_IMAGE_ENV = {"LISP_MAIN": _BAZEL_LISP_IMAGE_MAIN} -_ELFINATE = "//:elfinate.sar" -_DEFAULT_MALLOC = "@bazel_tools//tools/cpp:malloc" +_ELFINATE = "//:elfinate" _DEFAULT_LIBSBCL = "@local_sbcl//:c-support" -_COMPILATION_ORDERS = ["multipass", "serial", "parallel"] _LISP_LIBRARY_ATTRS = { "srcs": attr.label_list( allow_files = [".lisp", ".lsp"], doc = ("Common Lisp (`.lisp` or `.lsp`) source files. If there are " + - "multiple files in `srcs`, which other files in `srcs` are " + - "loaded before each file is compiled depends on the `order` " + - "attr."), + "multiple files in `srcs`, each is compiled with its " + + "predecessors loaded."), ), "deps": attr.label_list( providers = [LispInfo], @@ -62,24 +82,6 @@ _LISP_LIBRARY_ATTRS = { "forms together if those are between explicit (START-BLOCK) " + "and (END-BLOCK)."), ), - "order": attr.string( - default = "serial", - values = _COMPILATION_ORDERS, - doc = ( - "Compilation order, one of:\n" + - "\n" + - '`"serial"` (default) - Each source is compiled in an image ' + - "with previous sources loaded. (Note that in this " + - "configuration you should put a comment at the top of the " + - "list of srcs if there is more than one, so that formatters " + - "like Buildozer do not change the order.)\n" + - "\n" + - '`"multipass"` - Each source is compiled in an image with all ' + - "sources loaded.\n" + - "\n" + - '`"parallel"` - Each source is compiled independently.' - ), - ), "data": attr.label_list( allow_files = True, doc = ("Data available to this target and its consumers in the " + @@ -108,7 +110,7 @@ _LISP_LIBRARY_ATTRS = { allow_single_file = True, executable = True, cfg = "target", - default = Label(_BAZEL_LISP_IMAGE), + default = Label("//:lfc"), doc = ( "Lisp binary used as Bazel compilation image. This should be a " + "binary with the main function `#'bazel:main` defined in " + @@ -139,16 +141,6 @@ _LISP_LIBRARY_ATTRS = { "command-line-reference.html#flag--instrumentation_filter).`" ), ), - "_additional_dynamic_load_outputs": attr.label( - default = Label( - "//:additional_dynamic_load_outputs", - ), - providers = [BuildSettingInfo], - ), - # Do not add references, temporary attribute for find_cc_toolchain. - "_cc_toolchain": attr.label( - default = Label("@bazel_tools//tools/cpp:current_cc_toolchain"), - ), } _LISP_BINARY_ATTRS = dict(_LISP_LIBRARY_ATTRS) @@ -161,15 +153,12 @@ _LISP_BINARY_ATTRS.update({ "overridden by naming a function (or `nil` or `t`) in the " + "`LISP_MAIN` environment variable."), ), - "malloc": attr.label( - default = _DEFAULT_MALLOC, + "_malloc_dontuse": attr.label( + default = Label("@bazel_tools//tools/cpp:malloc"), providers = [CcInfo], doc = ("Target providing a custom malloc implementation. Same as " + "[`cc_binary.malloc`](https://docs.bazel.build/versions/" + - "master/be/c-cpp.html#cc_binary.malloc). Note that these " + - "rules do not respect [`--custom_malloc`]" + - "(https://docs.bazel.build/versions/master/" + - "command-line-reference.html#flag--custom_malloc)."), + "master/be/c-cpp.html#cc_binary.malloc)."), ), "stamp": attr.int( values = [-1, 0, 1], @@ -201,7 +190,7 @@ _LISP_BINARY_ATTRS.update({ "attr and use the default value."), ), "helper_script": attr.label( - default = None, + default = Label("//:imagesave.lisp"), allow_single_file = True, ), "_elfinate": attr.label( @@ -221,6 +210,11 @@ _LISP_BINARY_ATTRS.update({ _LISP_TEST_ATTRS = dict(_LISP_BINARY_ATTRS) _LISP_TEST_ATTRS.update({ + # For tests we want to avoid taking time to convert the Lisp text space to an ELF section. + # "allow-save-lisp" implements that, which doesn't really mean that a test may invoke + # SAVE-LISP. It just coincidental that allowing save-lisp implies NOT converting to ELF. + "allow_save_lisp": attr.bool(default = True, doc = "do not touch"), + "precompile_generics": attr.bool(default = False, doc = "do not touch"), "stamp": attr.int( values = [-1, 0, 1], default = 0, @@ -289,10 +283,16 @@ def _build_flags(ctx, add_features, verbose_level, instrument_coverage): if cc_toolchain.compiler in ["msan", "msan-track-origins"]: add_features = depset(["msan"], transitive = [add_features]) flags = ctx.actions.args() - flags.add( - "--compilation-mode", - ctx.var.get("LISP_COMPILATION_MODE", ctx.var["COMPILATION_MODE"]), - ) + + # Maybe there's an explicit LISP_COMPILATION_MODE. Usually not. + lisp_compilation_mode = ctx.var.get("LISP_COMPILATION_MODE", "none") + if lisp_compilation_mode == "none": + # if C++ wants -UNDEBUG then we want Lisp code safety, i.e. fastbuild + if "-UNDEBUG" in ctx.fragments.cpp.copts: + lisp_compilation_mode = "fastbuild" + else: # failing that, use the command-line-given ("-c") mode + lisp_compilation_mode = ctx.var["COMPILATION_MODE"] + flags.add("--compilation-mode", lisp_compilation_mode) flags.add("--bindir", ctx.bin_dir.path) flags.add_joined("--features", add_features, join_with = " ") @@ -312,6 +312,16 @@ def _list_excluding_depset(items, exclude): exclude_set = {item: True for item in exclude.to_list()} return [item for item in items if item not in exclude_set] +def _is_arm_cpu(ctx): + gnu_triple = ctx.toolchains["@bazel_tools//tools/cpp:toolchain_type"].cc.target_gnu_system_name + return gnu_triple[0:5] == "aarch" + +def _executor_for_ctx(ctx): + if _is_arm_cpu(ctx): + return {"requires-arch:arm": "1"} + else: + return {} + def lisp_compile_srcs( ctx, srcs = [], @@ -322,7 +332,6 @@ def lisp_compile_srcs( image = None, add_features = [], nowarn = [], - order = "serial", compile_data = [], verbose_level = 0, instrument_coverage = -1, @@ -343,8 +352,6 @@ def lisp_compile_srcs( image: Build image Target used to compile the sources. add_features: list of Lisp feature strings added by this target. nowarn: List of suppressed warning type strings. - order: Order in which to load sources, either "serial", "parallel", or - "multipass". compile_data: list of data dependency Targets whose outputs and runfiles are made available at load/compile time for this target and its consumers. @@ -365,9 +372,6 @@ def lisp_compile_srcs( lisp_info.fasls if there are srcs) - build_flags: Args to pass to all LispCompile and LispCore actions """ - if not order in _COMPILATION_ORDERS: - fail("order {} must be one of {}".format(order, _COMPILATION_ORDERS)) - name = ctx.label.name verbosep = verbose_level > 0 indexer_build = (ctx.var.get("GROK_ELLIPSIS_BUILD", "0") == "1") @@ -393,9 +397,6 @@ def lisp_compile_srcs( build_flags = build_flags, ) - multipass = (order == "multipass") - serial = (order == "serial") - build_image = image[DefaultInfo].files_to_run compile_image = build_image @@ -407,20 +408,11 @@ def lisp_compile_srcs( if indexer_build: deps_srcs.extend(indexer_metadata) - # Sources for this target loaded before compilation (after deps), passed to - # --load. What this contains depends on the compilation order: - # multipass: Contains everything - # parallel: Contains nothing - # serial: Contains previous entries in srcs (accumulated below) - load_srcs = srcs if multipass else [] + # Sources for this target loaded before compilation (after deps) + load_srcs = [] - # Arbitrary heuristic to reduce load on the build system by bundling - # FASL and source files load into one compile-image binary. compile_flags = ctx.actions.args() - if multipass: - nowarn = nowarn + ["redefined-method", "redefined-function"] - # buildozer: disable=print if verbosep: print("Target: " + name) @@ -428,8 +420,6 @@ def lisp_compile_srcs( print("Compile Img: " + compile_image.executable.short_path) fasls = [] - warnings = [] - hashes = [] output_fasl = ctx.actions.declare_file(name + ".fasl") if block_compile: # Compile all at once @@ -445,30 +435,14 @@ def lisp_compile_srcs( # Either we're compiling everything together for block-compilation # or there's only one src. compile_fasl = output_fasl - compile_warnings = ctx.actions.declare_file( - "{}~/{}.warnings".format(name, name), - ) else: # We're in the one-at-a-time case and there are multiple srcs. src = compile_srcs[0] stem = "{}~/{}".format(name, src.short_path[:-len(src.extension) - 1]) compile_fasl = ctx.actions.declare_file(stem + ".fasl") - compile_warnings = ctx.actions.declare_file(stem + ".warnings") - compile_hashes = [ - ctx.actions.declare_file("{}~/{}.hash".format( - name, - src.short_path[:-len(src.extension) - 1], - )) - for src in compile_srcs - ] fasls.append(compile_fasl) - warnings.append(compile_warnings) - hashes.extend(compile_hashes) - outs = [compile_fasl] - outs.extend(compile_hashes) - outs.append(compile_warnings) action_flags = ctx.actions.args() - action_flags.add_joined("--outs", outs, join_with = " ") + action_flags.add("--outs", compile_fasl) action_flags.add_joined("--srcs", compile_srcs, join_with = " ") action_flags.add_joined("--deps", deps_srcs, join_with = " ") action_flags.add_joined("--load", load_srcs, join_with = " ") @@ -477,8 +451,10 @@ def lisp_compile_srcs( action_flags.add("--block-compile") if block_compile_specified_only: action_flags.add("--block-compile-specified-only") + gc = ctx.var.get("LISPGC", "gencgc") + heapsize = "6GB" if gc == "gencgc" else "8GB" ctx.actions.run( - outputs = outs, + outputs = [compile_fasl], inputs = depset( compile_srcs + deps_srcs + load_srcs, transitive = [lisp_info.compile_data], @@ -489,7 +465,7 @@ def lisp_compile_srcs( env = _BAZEL_LISP_IMAGE_ENV, arguments = [ "--dynamic-space-size", - "5GB", # reduce from default of 16GB + heapsize, "compile", build_flags, compile_flags, @@ -497,9 +473,9 @@ def lisp_compile_srcs( ], executable = compile_image, toolchain = None, + execution_requirements = _executor_for_ctx(ctx), ) - if serial: - load_srcs.extend(compile_srcs) + load_srcs.extend(compile_srcs) if indexer_build: srcs = indexer_metadata + srcs @@ -507,8 +483,6 @@ def lisp_compile_srcs( lisp_info, srcs = srcs, fasls = [output_fasl] if srcs else [], - hashes = hashes, - warnings = warnings, ) return struct( lisp_info = lisp_info, @@ -524,56 +498,8 @@ def _cc_configure_features(ctx, cc_toolchain): unsupported_features = ctx.disabled_features, ) -# DEPS file is used to list all the Lisp sources for a target. -# It is a quick hack to make (bazel:load ...) work. -def _lisp_deps_manifest(ctx, lisp_info): - """Creates a file that lists all Lisp files needed by the target in order.""" - out = ctx.actions.declare_file(ctx.label.name + ".deps") - content = ctx.actions.args() - content.set_param_file_format("multiline") - content.add_joined( - lisp_info.features, - join_with = "\n", - format_each = "feature: %s", - ) - content.add_joined( - lisp_info.srcs, - join_with = "\n", - format_each = "src: %s", - ) - ctx.actions.write( - output = out, - content = content, - ) - return out - -def _lisp_dynamic_library(ctx, lisp_info): - cc_toolchain = find_cc_toolchain(ctx) - feature_configuration = _cc_configure_features(ctx, cc_toolchain) - linking_outputs = cc_common.link( - name = ctx.label.name, - actions = ctx.actions, - feature_configuration = feature_configuration, - cc_toolchain = cc_toolchain, - linking_contexts = [lisp_info.cc_info.linking_context], - output_type = "dynamic_library", - ) - return linking_outputs.library_to_link.dynamic_library - def _lisp_output_group_info(ctx, lisp_info, fasl_list): outputs = {"fasl": fasl_list} - - # Additional outputs for dynamic loading. These should only be used when - # explicitly requested, so condition the generation of the extra actions - # on a flag. (It might be better to just condition this on --output_groups, - # but that's not readable from Starlark.) - generate_dynamic_load_outputs = ( - ctx.attr._additional_dynamic_load_outputs[BuildSettingInfo].value - ) - if generate_dynamic_load_outputs: - outputs["deps_manifest"] = [_lisp_deps_manifest(ctx, lisp_info)] - outputs["dynamic_library"] = [_lisp_dynamic_library(ctx, lisp_info)] - return OutputGroupInfo(**outputs) def _lisp_instrumented_files_info(ctx): @@ -621,18 +547,23 @@ def _lisp_providers(ctx, lisp_info, fasl, executable = None): def _lisp_binary_impl(ctx): """Implementation for lisp_binary and lisp_test rules.""" name = ctx.label.name - core = ctx.actions.declare_file(name + ".core") + core_object_file = ctx.actions.declare_file(name + "-core.o") + + # allow_save_lisp implies that SBCL will write the .o file by itself. + # It's clearly the wrong name for an attribute with that semantics, but + # certain SWEs had stronger opinions than mine about what to name it. + # Since ARM does not support "full ELF" mode, we just use the nice .o file + if _is_arm_cpu(ctx) or ctx.attr.allow_save_lisp: + core = core_object_file # SBCL will produce an ELF '.o' file on its own + else: + core = ctx.actions.declare_file(name + ".core") # it's a preliminary step + verbose_level = max( ctx.attr.verbose, int(ctx.var.get("VERBOSE_LISP_BUILD", "0")), ) verbosep = verbose_level > 0 - # buildozer: disable=print - if verbosep: - print("~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~") - print("Core: %s" % core) - compile = lisp_compile_srcs( ctx = ctx, srcs = ctx.files.srcs, @@ -641,25 +572,19 @@ def _lisp_binary_impl(ctx): image = ctx.attr.image, add_features = ctx.attr.add_features, nowarn = ctx.attr.nowarn, - order = ctx.attr.order, compile_data = ctx.attr.compile_data, verbose_level = verbose_level, instrument_coverage = ctx.attr.instrument_coverage, ) - # TODO(czak): Add --hashes, and --warnings flags to bazl.main. lisp_info = compile.lisp_info fasls = lisp_info.fasls.to_list() - hashes = lisp_info.hashes.to_list() - warnings = lisp_info.warnings.to_list() if LispInfo in ctx.attr.image: # The image already includes some deps. included = ctx.attr.image[LispInfo] fasls = _list_excluding_depset(fasls, included.fasls) - hashes = _list_excluding_depset(hashes, included.hashes) - warnings = _list_excluding_depset(warnings, included.warnings) build_image = ctx.file.image @@ -671,8 +596,6 @@ def _lisp_binary_impl(ctx): content = ctx.actions.args() content.set_param_file_format("multiline") content.add_joined(fasls, format_joined = '(:deps\n "%s")', join_with = '"\n "') - content.add_joined(warnings, format_joined = '(:warnings\n "%s")', join_with = '"\n "') - content.add_joined(hashes, format_joined = '(:hashes\n "%s")', join_with = '"\n "') ctx.actions.write( output = specs, content = content, @@ -683,8 +606,6 @@ def _lisp_binary_impl(ctx): else: inputs = [specs, ctx.file.helper_script] inputs.extend(fasls) - inputs.extend(hashes) - inputs.extend(warnings) inputs = depset(inputs, transitive = [lisp_info.compile_data]) core_flags = ctx.actions.args() @@ -705,6 +626,7 @@ def _lisp_binary_impl(ctx): arguments = ["core", compile.build_flags, core_flags], executable = build_image, toolchain = None, + execution_requirements = _executor_for_ctx(ctx), ) cc_toolchain = find_cc_toolchain(ctx) @@ -722,10 +644,6 @@ def _lisp_binary_impl(ctx): # and another 40,000 over CALL-NEXT-METHOD and so on and so on. linkopts = ["-Wl,-no-pie"] - # Transform the .core file into a -core.o file, so that can be linked in - # with the C++ dependencies. - core_object_file = ctx.actions.declare_file(name + "-core.o") - link_additional_inputs = [] compilation_outputs = [ cc_common.create_compilation_outputs( # This file contains the SBCL core, essentially as '.data' in the @@ -736,37 +654,11 @@ def _lisp_binary_impl(ctx): pic_objects = depset([core_object_file]), ), ] - elfinate_args = ctx.actions.args() - if ctx.attr.allow_save_lisp: - # If we want to allow the binary to be used as a compilation image, the - # Lisp image has to stay in a form save-lisp-and-die understands. In - # this case, copy the entire native SBCL core into a binary blob in a - # normal '.o' file. - linker_script_file = ctx.actions.declare_file(name + "-syms.lds") - link_additional_inputs.append(linker_script_file) - elfinate_outs = [core_object_file, linker_script_file] - elfinate_cmd = ( - "$1 copy $2 $3 && nm -p $3 | " + - "awk '" + - '{print $2";"}BEGIN{print "{"}END{print "};"}' + - "' > $4" - ) - elfinate_args.add(ctx.executable._elfinate) - elfinate_args.add(core) - elfinate_args.add(core_object_file) - elfinate_args.add(linker_script_file) - linkopts.append( - "-Wl,--dynamic-list={}".format(linker_script_file.path), - ) - else: - # Otherwise, produce a '.s' file holding only compiled Lisp code and a + if not _is_arm_cpu(ctx) and not ctx.attr.allow_save_lisp: + # Produce a '.s' file holding only compiled Lisp code and a # '-core.o' containing the balance of the original Lisp spaces. assembly_file = ctx.actions.declare_file(name + ".s") elfinate_outs = [assembly_file, core_object_file] - elfinate_cmd = "$1 split $2 $3" - elfinate_args.add(ctx.executable._elfinate) - elfinate_args.add(core) - elfinate_args.add(assembly_file) # The .s file will get re-assembled before it's linked into the binary. # Note that this cc_common.compile action is declared before the @@ -780,30 +672,20 @@ def _lisp_binary_impl(ctx): srcs = [assembly_file], ) compilation_outputs.append(asm_compilation_output) + ctx.actions.run_shell( + outputs = elfinate_outs, + tools = [ctx.executable._elfinate], + inputs = [core], + command = ctx.executable._elfinate.path + " " + core.path + " " + assembly_file.path, + progress_message = "Elfinating Lisp core %{output}", + mnemonic = "LispElfinate", + toolchain = None, + ) - ctx.actions.run_shell( - outputs = elfinate_outs, - tools = [ctx.executable._elfinate], - inputs = [core], - command = elfinate_cmd, - arguments = [elfinate_args], - progress_message = "Elfinating Lisp core %{output}", - mnemonic = "LispElfinate", - toolchain = None, - ) - - # libc++ dependencies from cc_runtimes_toolchain. - cc_runtimes_toolchain = ctx.toolchains["@bazel_tools//tools/cpp:cc_runtimes_toolchain_type"] runtimes_ccinfos = [] - if cc_runtimes_toolchain: - runtimes_ccinfos += [ - target[CcInfo] - for target in cc_runtimes_toolchain.cc_runtimes_info.runtimes - if CcInfo in target - ] # The rule's malloc attribute can be overridden by the --custom_malloc flag. - malloc = ctx.attr._custom_malloc or ctx.attr.malloc + malloc = ctx.attr._custom_malloc or ctx.attr._malloc_dontuse linking_outputs = cc_common.link( name = name, actions = ctx.actions, @@ -831,7 +713,6 @@ def _lisp_binary_impl(ctx): ] + [info.linking_context for info in runtimes_ccinfos], stamp = ctx.attr.stamp, output_type = "executable", - additional_inputs = link_additional_inputs, ) return _lisp_providers( @@ -847,12 +728,7 @@ lisp_binary = rule( exec_groups = {"cpp_link": exec_group()}, attrs = _LISP_BINARY_ATTRS, fragments = ["cpp"], - toolchains = use_cc_toolchain() + [ - config_common.toolchain_type( - "@bazel_tools//tools/cpp:cc_runtimes_toolchain_type", - mandatory = False, - ), - ], + toolchains = use_cc_toolchain(), doc = """ Supports all of the same attributes as [`lisp_library`](#lisp_library), plus additional attributes governing the behavior of the completed binary. The @@ -870,18 +746,26 @@ Example: )""", ) -lisp_test = rule( +def lisp_test(name, **kwargs): + """Macro wrapper on lisp_test_rule appending an extra tag + + Args: + name: Rule name. + **kwargs: Passed through to lisp_binary""" + + tags = kwargs.pop("tags", []) + + moretags = ["notsan"] + alltags = tags + [x for x in moretags if x not in tags] + _lisp_test(name = name, tags = alltags, **kwargs) + +_lisp_test = rule( implementation = _lisp_binary_impl, executable = True, test = True, attrs = _LISP_TEST_ATTRS, fragments = ["cpp"], - toolchains = use_cc_toolchain() + [ - config_common.toolchain_type( - "@bazel_tools//tools/cpp:cc_runtimes_toolchain_type", - mandatory = False, - ), - ], + toolchains = use_cc_toolchain(), doc = """ Like [`lisp_binary`](#lisp_binary), for defining tests to be run with the [`test`](https://docs.bazel.build/versions/master/user-manual.html#test) @@ -919,6 +803,45 @@ def _lisp_library_impl(ctx): print("~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~") print("Library: %s" % ctx.label.name) + cc_toolchain = find_cc_toolchain(ctx) + + feature_configuration = cc_common.configure_features( + ctx = ctx, + cc_toolchain = cc_toolchain, + requested_features = ctx.features, + unsupported_features = ctx.disabled_features + ["module_maps"], + ) + + c_compile_variables = cc_common.create_compile_variables( + feature_configuration = feature_configuration, + cc_toolchain = cc_toolchain, + user_compile_flags = ctx.fragments.cpp.copts + ctx.fragments.cpp.conlyopts, + source_file = "dummyfile.c", + ) + + # We don't really need a complete C++ command-line, but I do not know how to detect + # presence of -D{thingy} in the opaque object that eventually becomes the command-line. + # So the technique of materializing the compiler invocation as a string list then + # searching for the flag of interest is perfectly adequate albeit brain-dead. + # + # And another problem: when I attempt to do this load() to use an abstract constant + # as you're "supposed to" + # load("@rules_cc//cc:action_names.bzl", "CPP_COMPILE_ACTION_NAME") + # then all tests in //lisp/devtools/bazel/macro-tests fail. Gimme a friggin break for once. + command_line = cc_common.get_memory_inefficient_command_line( + feature_configuration = feature_configuration, + action_name = "c++-compile", # should be CPP_COMPILE_ACTION_NAME ? + variables = c_compile_variables, + ) + if "-D_LIBCPP_GOOGLE3_ENABLE_SIZE_BASED_VECTOR" in command_line: + augment_lisp_features = ["size-based-stdvector"] + ctx.attr.add_features + else: + augment_lisp_features = ctx.attr.add_features + if "-DADDRESS_SANITIZER" in command_line or "-DHWADDRESS_SANITIZER" in command_line: + augment_lisp_features = ["address-sanitizer"] + augment_lisp_features + if "-DNDEBUG" in command_line and not "-UNDEBUG" in command_line: + augment_lisp_features = ["copt-ndebug"] + augment_lisp_features + compile = lisp_compile_srcs( ctx = ctx, srcs = ctx.files.srcs, @@ -927,9 +850,8 @@ def _lisp_library_impl(ctx): block_compile = ctx.attr.block_compile, block_compile_specified_only = ctx.attr.block_compile_specified_only, image = ctx.attr.image, - add_features = ctx.attr.add_features, + add_features = augment_lisp_features, nowarn = ctx.attr.nowarn, - order = ctx.attr.order, compile_data = ctx.attr.compile_data, verbose_level = verbose_level, instrument_coverage = ctx.attr.instrument_coverage, diff --git a/sbcl.lisp b/sbcl.lisp index 7999b66..7038031 100644 --- a/sbcl.lisp +++ b/sbcl.lisp @@ -7,44 +7,26 @@ ;;; Utilities for Bazel Lisp and their implementation in SBCL. ;;; -;; Default optimization settings. -; #-dbg (declaim (optimize (speed 3) (safety 1))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - ;; MD5 pulls in SB-ROTATE-BYTE which makes it impossible - ;; to compile either of those from fresh upstream sources without some magic. - (require :sb-md5)) - (defpackage #:bazel.sbcl - (:use #:common-lisp #:sb-thread #:sb-alien #:bazel.utils) - (:import-from #:sb-md5 #:md5sum-file) - (:export #:compile-files + (:use #:common-lisp #:sb-thread #:sb-alien) + (:export #:always-block-compile-file-p + #:compile-files + #:c++-mangle + #:c-symbol-existsp #:exit #:run #:inline-function-p - #:function-has-transforms-p - #:getenv #:unsetenv #:chdir + #:getenv #:unsetenv #:command-line-arguments #:program-name #:default-toplevel-loop #:mute-output-streams #:save-lisp-and-die - #:dump-alien-symbols - #:dump-extern-symbols - #:dump-dynamic-list-lds - #:combine-run-time-and-core #:md5sum-file #:set-interpret-mode - #:set-interactive-mode - #:setup-readtable #:remove-extra-debug-info #:name-closure #:with-creating-find-package - #:with-default-package - ;; threading - #:make-thread - #:join-thread - #:with-recursive-lock - #:make-mutex #:mutex)) + #:with-default-package)) (in-package #:bazel.sbcl) @@ -74,12 +56,6 @@ "Returns non-nil when the FUNCTION is declared inline." (eq (sb-int:info :function :inlinep function) 'inline)) -(defun function-has-transforms-p (function) - "Returns non-nil if the FUNCTION has transforms." - (or (sb-c::info :function :source-transform function) - (let ((info (sb-c::info :function :info function))) - (and info (sb-c::fun-info-transforms info))))) - (defun getenv (variable) "Returns the value of the environment VARIABLE." (sb-ext:posix-getenv variable)) @@ -115,20 +91,6 @@ (setf (sb-kernel:%fun-name closure) name) closure) -(defun remove-extra-debug-info () - "Removes debug info like docstrings and xrefs." - (sb-vm::map-allocated-objects - (lambda (obj type size) - (declare (ignore size)) - (when (= type sb-vm:code-header-widetag) - (dotimes (i (sb-kernel:code-n-entries obj)) - (let ((f (sb-kernel:%code-entry-point obj i))) - (setf (sb-kernel:%simple-fun-info f) 'function) - ;; Preserve source forms, assuming we want them if they exist. - (setf (sb-kernel:%simple-fun-source f) - (sb-kernel:%simple-fun-lexpr f)))))) - :all)) - ;;; ;;; Precompile generic functions. ;;; TODO(czak): This needs to go into SBCL upstream. @@ -260,9 +222,6 @@ (unless (find (symbol-package s) *skip-precompile-packages*) (when (precompile s) (precompile `(setf ,s))))) - (when (plusp verbose) - (bazel.log:info "Precompiled ~D (~D% out of ~D) generic functions.~%" - count (round (* 100 count) all) all)) (values count all)))) ;;; @@ -273,66 +232,112 @@ "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))) (setf sb-ext:*evaluator-mode* (if (eq compile-mode :load) :interpret :compile)) - (bazel.log:vvv "Set interpret mode to: ~A" sb-ext:*evaluator-mode*) sb-ext:*evaluator-mode*) -(defun set-interactive-mode (&optional (interactive-p t)) - "If INTERACTIVE-P is true, the debugger will be enabled." - (if interactive-p - (sb-ext:enable-debugger) - (sb-ext:disable-debugger))) - ;;; ;;; Reading lisp files. ;;; -(defun setup-readtable (rt) - (setf (sb-ext:readtable-base-char-preference rt) :both) - rt) - -(defvar *in-find-package* nil "Prevents cycles in make-package") -(defvar *with-creating-find-package-mutex* (make-mutex :name "with-creating-find-package-mutex")) - -(defun call-with-augmented-find-package (body &key (use '("COMMON-LISP")) (default nil)) - "Calls the BODY after making sure that the reader - will not error on unknown packages or not exported symbols. - USE is the set of packages to use by the new package. - This affects _all_ threads' calls to FIND-PACKAGE, and - is generally not appropriate to use in production code" - (declare (function body)) - ;; The instant that ENCAPSULATE stores the new definition of FIND-PACKAGE, we must - ;; accept that any thread - whether already running, or newly created - can access - ;; our local function as a consequence of needing FIND-PACKAGE for any random reason. - ;; Were the closure allocated on this thread's stack, then this function's frame - ;; would be forbidden from returning until no other thread was executing the code - ;; that was made globally visible. Since there's no way to determine when the last - ;; execution has ended, the FLET body has indefinite, not dynamic, extent. - (flet ((creating-find-package (f name) - (or (funcall f name) - default - (unless *in-find-package* - (let ((*in-find-package* t)) - (make-package name :use use)))))) - (with-recursive-lock (*with-creating-find-package-mutex*) - (sb-int:encapsulate 'find-package 'create #'creating-find-package) - (unwind-protect - (handler-bind ((package-error #'continue)) - (funcall body)) - (sb-int:unencapsulate 'find-package 'create))))) - -(defmacro with-creating-find-package ((&key (use '("COMMON-LISP"))) &body body) - "Executes body in an environment where FIND-PACKAGE will not signal an unknown package error. - Instead it will create the package with the missing name with the provided USE packages." - `(call-with-augmented-find-package (lambda () ,@body) :use ',use)) - -(defmacro with-default-package ((default) &body body) - "Executes body in an environment where FIND-PACKAGE will not signal an unknown package error. - Instead it will return the DEFAULT package." - `(call-with-augmented-find-package (lambda () ,@body) :default ,default)) +(defun always-block-compile-file-p (file) + "Return true if :block-compile should be enabled for FILE" + (declare (ignore file)) + nil) (defun compile-files (names &rest rest) "Call COMPILE-FILE on NAMES, which must be singular despite being named NAMES, passing through REST unaltered." (if (typep names '(or atom (cons string null))) - (apply #'compile-file (if (atom names) names (car names)) rest) + (let ((source (if (atom names) names (car names)))) + (when (find-package "SB-COVER") + ;; no effect if coverage isn't enabled + (funcall (find-symbol "ENABLE-COVERAGE-LOGGING" "SB-COVER"))) + (apply #'compile-file source + :block-compile (or (getf rest :block-compile) + (always-block-compile-file-p source)) + rest)) (error "Multiple file support is incomplete"))) + +(defun md5sum-file (file) + "Run external md5sum program on FILE" + (let ((process (sb-ext:run-program "md5sum" (list (namestring (merge-pathnames file))) + :output :stream :search t))) + (assert (zerop (sb-ext:process-exit-code process))) + (let ((hex (subseq (read-line (sb-ext:process-output process)) 0 32)) + (result (make-array 16 :element-type '(unsigned-byte)))) + (dotimes (i 16 result) + (setf (aref result i) + (parse-integer hex :start (* i 2) :end (* (1+ i) 2) :radix 16)))))) + +;;; This belongs somewhere in SB-ALIEN, but only in theory, because the mangling +;;; algorithm depends technically on the C compiler. It so happens that we use LLVM +;;; which uses the mangling specification developed for Itanium. The real mangler +;;; takes over 6 thousand lines of code to express. This is a far cry from that. +(defun c++-mangle (name arg-types &optional const) ; NOLINT + "Produce the C linkage name for C++ function NAME with ARG-TYPES" + (labels ((typemangle (spec) + (apply #'concatenate 'string + (mapcar #'mangle-modifier (sb-int:ensure-list spec)))) + (mangle-modifier (x) + (string + (cond ((case x + (* #\P) + (integer #\i) + (sb-alien:long #\l) + (sb-alien:unsigned-long #\m) + (sb-alien:double #\d) + (sb-alien:void #\v) + (character #\c) + (boolean #\b))) + ;; package-insensitive comparison + ((string= x "CONST") #\K) + ((string= x "REF") #\R) + ((string= x "string_view") + ;; the mangled string demangles to + ;; "std::__u::basic_string_view >" + ;; #\N => nesting, "St" => std::, #\I => template parameter list + ;; "S_" => backreference to std::__u and so on + (if (member :msan *features*) + "NSt6__msan17basic_string_viewIcNS_11char_traitsIcEEEE" + "NSt3__u17basic_string_viewIcNS_11char_traitsIcEEEE")) + ((stringp x) (format nil "~D~A" (length x) x)) + (t (error "Unhandled C++ name")))))) + (format nil "_Z~A~{~A~}" + (if (stringp name) + (format nil "~D~A" (length name) name) + (with-output-to-string (s) + (write-char #\N s) + (when const (write-char #\K s)) + (dolist (part name) (format s "~D~A" (length part) part)) + (write-char #\E s))) + (if arg-types (mapcar #'typemangle arg-types) '(#\v))))) + +(defun c-symbol-existsp (sym) + "True if and only if &SYM is nonzero in an ELF binary" + (let ((alien-linkage-space-start (find-symbol "ALIEN-LINKAGE-SPACE-START" "SB-VM"))) + (unless alien-linkage-space-start + (return-from c-symbol-existsp nil)) + (macrolet ((compute-offset () + (let ((accessor (find-symbol "ALIEN-LINKAGE-ELEMENT-OFFSET" "SB-VM"))) + (if accessor + `(,accessor index t) + `(+ (* index sb-vm:alien-linkage-table-entry-size) 8))))) + (let ((index (gethash sym (car sb-sys:*linkage-info*)))) + (and index + ;; check that alien linkage table entry doesn't point to undefined-tramp + (/= (sb-sys:sap-ref-word (sb-sys:int-sap (symbol-value alien-linkage-space-start)) + (compute-offset)) + (sb-fasl:get-asm-routine (or (find-symbol "UNDEFINED-ALIEN-TRAMP" "SB-VM") + (find-symbol "UNDEFINED-TRAMP" "SB-VM"))))))))) + +(defun maybe-save-coverage () + "If ${COVERAGE} is set, writes coverage data to a file in ${COVERAGE_DIR}. The file has the .dat + extension and is in LCOV format. By convention, for Lisp coverage the filname starts with + 'lispcov'." + (when (getenv "COVERAGE") + (let ((coverage-dir (getenv "COVERAGE_DIR"))) + (unless coverage-dir + (error "COVERAGE is set, but COVERAGE_DIR is not.")) + (funcall (find-symbol "LCOV-REPORT" "SB-COVER") + (format nil "~A/lispcov-~A.dat" coverage-dir (sb-unix:unix-getpid)))))) + +(pushnew 'maybe-save-coverage sb-ext:*exit-hooks*) diff --git a/test/BUILD b/test/BUILD index 431f2c1..0fdbf3b 100644 --- a/test/BUILD +++ b/test/BUILD @@ -7,7 +7,7 @@ # Copyright 2015 Google Inc. All rights reserved. # Author: andrzejwalczak@google.com (Andrzej Walczak) # Description: -# Test directory for the Lisp Skylark build rules. +# Test directory for the Lisp Starlark build rules. load( "//:rules.bzl", @@ -16,8 +16,6 @@ load( "lisp_test", ) -package(default_applicable_licenses = ["//:license"]) - licenses(["notice"]) lisp_library( @@ -76,17 +74,12 @@ lisp_library( "c.lisp", "d.lisp", ], - order = None, ) lisp_library( name = "lib2", srcs = ["test.lisp"], - nowarn = [ - "deprecation", - "optional-and-key", - "implicit-generic", - ], + nowarn = ["optional-and-key"], deps = [":lib1"], ) @@ -142,34 +135,6 @@ lisp_test( image = ":lisp-test-image", ) -CIRCULAR_SRCS = [ - "circular1.lisp", - "circular2.lisp", - "circular3.lisp", - "test-circular.lisp", -] - -lisp_test( - name = "circular", - srcs = CIRCULAR_SRCS, - order = "multipass", -) - -lisp_library( - name = "undefined-macro-error", - srcs = [ - # Ordered - "undefined-macro-reference.lisp", - "undefined-macro-definition.lisp", - ], -) - -lisp_test( - name = "undefined-macro-test", - srcs = ["undefined-macro-test.lisp"], - deps = [":undefined-macro-error"], -) - lisp_test( name = "args-test", srcs = ["args-test.lisp"], @@ -193,45 +158,8 @@ lisp_test( srcs = ["main-test.lisp"], ) -lisp_library( - name = "wrong-arg-count-lib", - srcs = ["wrong-arg-count.lisp"], -) - -lisp_test( - name = "wrong-arg-count-test", - srcs = ["wrong-arg-count-test.lisp"], - nowarn = ["wrong-argument-count"], - deps = [":wrong-arg-count-lib"], -) - # For demonstration purposes. lisp_test( name = "compilation-mode", srcs = ["compilation-mode.lisp"], ) - -# Test eval main. -lisp_test( - name = "eval-main", - srcs = ["eval-main.lisp"], - main = "(foo :x 1 :y 2)", -) - -lisp_test( - name = "eval-main-2", - srcs = ["eval-main.lisp"], - main = "(progn (foo :x 1 :y 2))", -) - -lisp_test( - name = "eval-main-3", - srcs = ["eval-main.lisp"], - main = "(if nil (break) (foo :x 1 :y 2))", -) - -lisp_test( - name = "stack-alloc", - srcs = ["stack-alloc.lisp"], - nowarn = ["stack-allocate-note"], -) diff --git a/test/circular1.lisp b/test/circular1.lisp deleted file mode 100644 index 42a01e4..0000000 --- a/test/circular1.lisp +++ /dev/null @@ -1,13 +0,0 @@ -;;; Copyright 2015-2020 Google LLC -;;; -;;; Use of this source code is governed by an MIT-style -;;; license that can be found in the LICENSE file or at -;;; https://opensource.org/licenses/MIT. - -(in-package :cl-user) - -(defmacro foo () - "foo") - -(defun use-bar () - (bar)) diff --git a/test/circular2.lisp b/test/circular2.lisp deleted file mode 100644 index 077daee..0000000 --- a/test/circular2.lisp +++ /dev/null @@ -1,13 +0,0 @@ -;;; Copyright 2015-2020 Google LLC -;;; -;;; Use of this source code is governed by an MIT-style -;;; license that can be found in the LICENSE file or at -;;; https://opensource.org/licenses/MIT. - -(in-package :cl-user) - -(defmacro bar () - "bar") - -(defun use-baz () - (baz)) diff --git a/test/circular3.lisp b/test/circular3.lisp deleted file mode 100644 index c134888..0000000 --- a/test/circular3.lisp +++ /dev/null @@ -1,13 +0,0 @@ -;;; Copyright 2015-2020 Google LLC -;;; -;;; Use of this source code is governed by an MIT-style -;;; license that can be found in the LICENSE file or at -;;; https://opensource.org/licenses/MIT. - -(in-package :cl-user) - -(defmacro baz () - "baz") - -(defun use-foo () - (foo)) diff --git a/test/features-test.lisp b/test/features-test.lisp index f61522a..2b9d462 100644 --- a/test/features-test.lisp +++ b/test/features-test.lisp @@ -9,12 +9,8 @@ (defun main () (assert (eq :xyz (bazel.main::to-feature :xyz))) (assert (eq :xyz (bazel.main::to-feature "xyz"))) - (assert (eq 'cl-user::xyz (bazel.main::to-feature "cl-user::xyz"))) - (assert (eq 'cl-user::xyz1234567890 - (bazel.main::to-feature "cl-user:xyz1234567890"))) - (assert (null (ignore-errors (bazel.main::to-feature "123")))) - (assert (null (ignore-errors (bazel.main::to-feature "()")))) + (assert (eq :|123| (bazel.main::to-feature "123"))) (assert (null (ignore-errors (bazel.main::to-feature 123)))) (assert (find :bazel *features*)) ; NOLINT diff --git a/test/stack-alloc.lisp b/test/stack-alloc.lisp deleted file mode 100644 index 1c40e6d..0000000 --- a/test/stack-alloc.lisp +++ /dev/null @@ -1,20 +0,0 @@ -;;; Copyright 2015-2020 Google LLC -;;; -;;; Use of this source code is governed by an MIT-style -;;; license that can be found in the LICENSE file or at -;;; https://opensource.org/licenses/MIT. - -;;; Generates a stack-allocation note to test the -;;; nowarn = ["stack-allocate-note"] -;;; parameter. -;;; - -(in-package :cl-user) - -(defun stack-alloc-list (size) - (let ((l (make-list size))) - (declare (dynamic-extent l)) - (length l))) - -(defun main () - (format t "len: ~A~%" (stack-alloc-list 63))) diff --git a/test/test-circular.lisp b/test/test-circular.lisp deleted file mode 100644 index 9cc9557..0000000 --- a/test/test-circular.lisp +++ /dev/null @@ -1,10 +0,0 @@ -;;; Copyright 2015-2020 Google LLC -;;; -;;; Use of this source code is governed by an MIT-style -;;; license that can be found in the LICENSE file or at -;;; https://opensource.org/licenses/MIT. - -(defun main () - (use-foo) - (use-bar) - (use-baz)) diff --git a/test/undefined-macro-definition.lisp b/test/undefined-macro-definition.lisp deleted file mode 100644 index 1b5b9c8..0000000 --- a/test/undefined-macro-definition.lisp +++ /dev/null @@ -1,9 +0,0 @@ -;;; Copyright 2015-2020 Google LLC -;;; -;;; Use of this source code is governed by an MIT-style -;;; license that can be found in the LICENSE file or at -;;; https://opensource.org/licenses/MIT. - -(defmacro undefined-macro (arg) - "A macro that takes ARG. The macro is undefined in t.lisp." - `(oddp ,arg)) diff --git a/test/undefined-macro-reference.lisp b/test/undefined-macro-reference.lisp deleted file mode 100644 index f031f11..0000000 --- a/test/undefined-macro-reference.lisp +++ /dev/null @@ -1,9 +0,0 @@ -;;; Copyright 2015-2020 Google LLC -;;; -;;; Use of this source code is governed by an MIT-style -;;; license that can be found in the LICENSE file or at -;;; https://opensource.org/licenses/MIT. - -(defun undefined-macro-reference (arg) - "A function that takes ARG and invokes undefined macro C." - (undefined-macro arg)) diff --git a/test/undefined-macro-test.lisp b/test/undefined-macro-test.lisp deleted file mode 100644 index 1d3c825..0000000 --- a/test/undefined-macro-test.lisp +++ /dev/null @@ -1,45 +0,0 @@ -;;; Copyright 2015-2020 Google LLC -;;; -;;; Use of this source code is governed by an MIT-style -;;; license that can be found in the LICENSE file or at -;;; https://opensource.org/licenses/MIT. - -(defvar *undefined-function-signaled-p* nil) - -;; The bazel.main represents its action as the ACTION datastructure, which contains -;; all the necessary inputs, processing parameters, and intermediate info. -;; One of the lists stored on the action object are the deferred warnings which are -;; checked by a BINARY action at the end when the FINISH-ACTION method is called. -;; An easy way to proof that there was a deferred warning is to check this field -;; on the action before the FINISH-ACTION runs. -;; -;; The following code will check that there was a deferred warning from the BINARY command -;; and than empty this field so that the build and test can complete without failures. -;; The generic below runs BEFORE the binary image is written at the build time. -;; -;; This is possible because we load all the compiled FASLs into the binary image before -;; we dump the image as the build output artifact. When loading the FASLs the generic below -;; will be found at the method dispatch time. - -(defmethod bazel.main:finish-action :before ((action bazel.main:action) (command (eql :core))) - "Checks ACTION if there was an undefined-function warning for the core COMMAND." - ;; TODO(czak): Need to provide a better path here. - (assert (equalp (bazel.main:action-deferred-warnings action) - '(("third_party/lisp/bazel/test/undefined-macro-reference.lisp" - :UNDEFINED-FUNCTION UNDEFINED-MACRO)))) - (setf *undefined-function-signaled-p* t) - (setf (bazel.main:action-deferred-warnings action) nil)) - -;; This MAIN function runs at the bazel test run time. -;; Since the UNDEFINED-MACRO-REFERENCE has been compiled as undefined function, -;; the call to it will result in the UNDEFINED-FUNCTION warning. -;; The above generic that runs before the FINISH-ACTION takes care that this code compiles. - -(defun main () - "The test expects that there was an undefined function." - (assert *undefined-function-signaled-p*) - (handler-case - (progn - (format t "~A~%" (undefined-macro-reference 1)) - (error "there should be an undefined-function warning")) - (undefined-function (e) e))) diff --git a/test/wrong-arg-count-test.lisp b/test/wrong-arg-count-test.lisp deleted file mode 100644 index 68af26a..0000000 --- a/test/wrong-arg-count-test.lisp +++ /dev/null @@ -1,24 +0,0 @@ -;;; Copyright 2015-2020 Google LLC -;;; -;;; Use of this source code is governed by an MIT-style -;;; license that can be found in the LICENSE file or at -;;; https://opensource.org/licenses/MIT. - -(defun wrong-arg-count-fun3 (a b) (+ a b)) - -(eval-when (:load-toplevel) - (defun test () - (wrong-arg-count-fun 10) - (wrong-arg-count-fun2 10) - (wrong-arg-count-fun3 10))) - -(defvar *muffled-warnings-count* #.(bazel.main::action-muffled-warnings-count bazel.main:*action*)) - -(eval-when (:load-toplevel) - (unless (= 3 *muffled-warnings-count*) - (format t "Muffled-warnings-count: ~D != 3~%" *muffled-warnings-count*) - (format t "KNOWN BUG: Wrong argument count is not signaled for interpreted functions.!!!~%"))) - -(defun main () - (unless (= 3 *muffled-warnings-count*) - (warn "KNOWN BUG: Wrong argument count is not signaled for interpreted functions!!!"))) diff --git a/test/wrong-arg-count.lisp b/test/wrong-arg-count.lisp deleted file mode 100644 index fa0794e..0000000 --- a/test/wrong-arg-count.lisp +++ /dev/null @@ -1,13 +0,0 @@ -;;; Copyright 2015-2020 Google LLC -;;; -;;; Use of this source code is governed by an MIT-style -;;; license that can be found in the LICENSE file or at -;;; https://opensource.org/licenses/MIT. - -;; Tests the wrong argument count. -;; - -(defun wrong-arg-count-fun (a b) (+ a b)) - -(declaim (ftype (function (number number) (values number &optional)) wrong-arg-count-fun2)) -(defun wrong-arg-count-fun2 (a b) (+ a b)) diff --git a/utils.lisp b/utils.lisp index 2b746f5..57d59be 100644 --- a/utils.lisp +++ b/utils.lisp @@ -9,32 +9,14 @@ (defpackage #:bazel.utils (:use #:cl) - (:export #:octet - #:octets - #:simple-octets - #:nconcf + (:export #:nconcf #:prefixp #:strip-prefix - #:delete-existing - #:delete-read-only - #:dohash #:split - #:to-keyword - #:write-stringz - #:read-stringz - #:read-u64 - #:write-u64 - #:with-continue-on-error - #:funcall-named - #:funcall-named*)) + #:to-keyword)) (in-package #:bazel.utils) - -(deftype octet () '(unsigned-byte 8)) -(deftype octets () '(vector octet)) -(deftype simple-octets () '(and octets simple-array)) - (define-modify-macro nconcf (&rest lists) nconc "Helper macro doing an nconc and setf to the first argument.") @@ -52,23 +34,6 @@ (values (subseq string (length prefix)) t) (values string nil))) -(defun delete-existing (filename) - "Remove FILENAME from disk if it exists and its directory is writable" - (when (probe-file filename) - (delete-file filename))) - -(defun delete-read-only (filename &optional (mode :supersede)) - "Remove FILENAME from disk if it is readonly. -MODE can be :APPEND or :SUPERSEDE. True if file was deleted." - (when (probe-file filename) - (handler-case - (with-open-file (f filename :direction :output :if-exists mode) nil) - (file-error () (delete-file filename))))) - -(defmacro dohash ((k v table) &body body) - "Iterate through the hash TABLE binding the keys to K and values to V." - `(loop for ,k being the hash-keys in ,table using (hash-value ,v) do ,@body)) - (defun split (string &key (by #\Space)) "Split the STRING by the separator BY into a list. Empty strings are not included." (declare (type (or string null) string) (character by)) @@ -84,72 +49,3 @@ MODE can be :APPEND or :SUPERSEDE. True if file was deleted." "Transforms the STRING designator into a keyword. The string is interned in the upper case into the keyword package." (intern (string-upcase string) :keyword)) - -(defun write-stringz (string out) - "Write a 0 terminated STRING to the OUT stream." - (declare (string string) (stream out)) - (loop for c across string do - ;; This assumes that the CHAR-CODE is an octet. - (write-byte (char-code c) out)) - (write-byte 0 out)) - -(defun read-stringz (stream) - "Read a 0 terminated string from the STREAM." - (declare (stream stream)) - (coerce - (loop for code = (read-byte stream nil) - until (zerop code) - collect (code-char code)) - 'string)) - -(defun read-u64 (in) - "Reads 8 bytes from the IN stream and returns an integer." - (declare (stream in)) - (let ((u64 0)) - (declare (type (unsigned-byte 64) u64)) - (dotimes (i 8) - (setf (ldb (byte 8 (* i 8)) u64) (read-byte in))) - u64)) - -(defun write-u64 (u64 out) - "Writes 8 bytes representation of u64 to the OUT stream." - (declare (type (unsigned-byte 64) u64) (stream out)) - (dotimes (i 8) - (write-byte (ldb (byte 8 (* i 8)) u64) out))) - -(defun funcall-named (name &rest args) - "Call a function with NAME composed of package and function name. Passes ARGS to the function. - If the package is not found, nothing is called and NIL is returned." - (let ((split (split name :by #\:))) - (assert (= 2 (length split))) ; NOLINT - (let ((package (find-package (first split)))) - (when package - (let ((function (find-symbol (second split) package))) - (assert function) ; NOLINT - (assert (fboundp function)) ; NOLINT - (apply function args)))))) - -(defun funcall-named* (name &rest args) - "Call a function with NAME composed of package and function name. Passes ARGS to the function. - If the function is not found, nothing is called and NIL is returned." - (let ((split (split name :by #\:))) - (assert (= 2 (length split))) ; NOLINT - (let* ((package (find-package (first split))) - (function (and package (find-symbol (second split) package)))) - (when (and function (fboundp function)) - (apply function args))))) - -(defun %with-continue-on-error (function test) - "Call FUNCTION while wrapping it conditionally (TEST) into a HANDLER-BIND that - continues from the error if the continue restart is found." - (if test - (handler-bind ((error - (lambda (c) (declare (ignore c)) - (let ((continue (find-restart 'continue))) - (when continue (invoke-restart continue)))))) - (funcall function)) - (funcall function))) - -(defmacro with-continue-on-error ((&key (when t)) &body body) - "Call CONTINUE for all errors. WHEN is an optional condition form." - `(%with-continue-on-error (lambda () ,@body) ,when)) diff --git a/warning.lisp b/warning.lisp index 813268b..09c7708 100644 --- a/warning.lisp +++ b/warning.lisp @@ -11,35 +11,18 @@ (cL:defpackage #:bazel.warning (:use #:common-lisp) (:export #:style - #:undefined-variable-p - #:undefined-variable-warning - #:unused-variable #:undefined-function-p #:undefined-function-warning - #:inline-used-before-definition #:inlining-notinline - #:compiler-macro-after-function-use #:redefined-macro #:redefined-function #:redefined-method #:redefined-generic - #:redefined-package #:redefine-warning - #:conflicting-ftype-declaration - #:changed-ftype-proclamation - #:wrong-argument-count #:optional-and-key - #:deleted-code #:type-style #:type-conflict - #:complex-lexical-environment - #:implicit-generic - #:uninteresting-condition - #:deprecation - #:show-notes - #:stack-allocate-note - #:fail-stack-allocate-notes - #:fail-inline-expansion-limit)) + #:uninteresting-condition)) (cl:in-package #:bazel.warning) @@ -74,27 +57,6 @@ Returns two values: a boolean and a name symbol of the thing." (and (eq (second args) kind) (values t (third args)))))))) -(defun undefined-variable-p (warning) - "Is WARNING an undefined variable warning? -This returns two values: a boolean and a name symbol of the variable." - (%undefined-p warning :variable)) - -(deftype undefined-variable-warning () - "Generic type of undefined function variable." - '(and warning (satisfies undefined-variable-p))) - -(defun unused-variable-p (warning) - "True if WARNING is about an unused variable." - #+sbcl - (when (typep warning '(and warning simple-condition)) ; not really a simple-warning - (let ((control (format-control-string-or-nil warning))) - (and (search "variable" control :test #'char-equal) - (search "defined but never used" control :test #'char-equal))))) - -(deftype unused-variable () - "Type of warning about an unused variable." - '(and style-warning (satisfies unused-variable-p))) - (defun undefined-function-p (warning) "Is WARNING an undefined function warning? This returns two values: a boolean and a name symbol of the function." @@ -104,18 +66,6 @@ This returns two values: a boolean and a name symbol of the function." "Generic type of undefined function warning." '(and warning (satisfies undefined-function-p))) -(defun inline-used-before-definition-p (warning) - "True if WARNING is a warning about an early use of function declared inline later." - #-sbcl nil - #+sbcl - (when (typep warning '(and warning simple-condition)) - (let ((control (format-control-string-or-nil warning))) - (search "previously compiled. A declaration of NOTINLINE" control)))) - -(deftype inline-used-before-definition () - "Type of warning for early use of functions with inline or compiler-macro optimizations." - '(and warning (satisfies inline-used-before-definition-p))) - (defun inlining-notinline-p (warning) "True if WARNING is about an attempt to inline a notinline function." #-sbcl nil @@ -126,18 +76,6 @@ This returns two values: a boolean and a name symbol of the function." "Type of warning when trying to inline a notinline function." '(and warning (satisfies inlining-notinline-p))) -(defun compiler-macro-after-function-use-p (warning) - "True for a WARNING about a function used before the compiler-macro was defined." - #-sbcl nil - #+sbcl - (when (typep warning '(and warning simple-condition)) - (let ((control (format-control-string-or-nil warning))) - (search "compiled before a compiler-macro was defined for it" control)))) - -(deftype compiler-macro-after-function-use () - "Type of warning for early use of functions with compiler-macros." - '(and warning (satisfies compiler-macro-after-function-use-p))) - (defun redefined-macro-p (warning) "Is WARNING a redefined macro compiler warning?" #+sbcl (typep warning 'sb-kernel:redefinition-with-defmacro)) @@ -154,33 +92,6 @@ This returns two values: a boolean and a name symbol of the function." "Type of a redefined function warning." '(and warning (satisfies redefined-function-p))) -(defun changed-ftype-proclamation-p (warning) - "True when WARNING is a warning about changed function FTYPE." - #+sbcl - (when (typep warning '(and warning simple-condition)) - (let ((control (format-control-string-or-nil warning)) - (args (simple-condition-format-arguments warning))) - (and (search "function" control) - (search "clobbers" control) - (search "proclamation" control) - (member 'ftype args))))) - -(deftype changed-ftype-proclamation () - "Type of a warning for a changed FTYPE proclamation." - '(and warning (satisfies changed-ftype-proclamation-p))) - -(defun conflicting-ftype-declaration-p (warning) - "True when WARNING is a warning about a new, conflicting FTYPE declaration." - #+sbcl - (when (typep warning '(and warning simple-condition)) - (let ((control (format-control-string-or-nil warning))) - (and (search "The previously declared FTYPE" control) - (search "conflicts with the definition type" control))))) - -(deftype conflicting-ftype-declaration () - "Type of a warning for a conflicting FTYPE declaration." - '(and warning (satisfies conflicting-ftype-declaration-p))) - (defun redefined-method-p (warning) "Is WARNING a redefined method compiler warning?" #+sbcl (typep warning 'sb-kernel:redefinition-with-defmethod)) @@ -197,14 +108,6 @@ This returns two values: a boolean and a name symbol of the function." "Type of a redefined generic warning." '(and warning (satisifies redefined-generic-p))) -(defun redefined-package-p (warning) - "Is WARNING a redefined package/package variance compiler warning?" - #+sbcl (typep warning 'sb-int:package-at-variance)) - -(deftype redefined-package () - "Type of a redefined package warning." - '(and warning (satisfies redefined-package-p))) - (defun redefine-warning-p (warning) "Is WARNING a generic redefinition warning?" #+sbcl (typep warning 'sb-kernel:redefinition-warning)) @@ -213,17 +116,6 @@ This returns two values: a boolean and a name symbol of the function." "Type of a general redefinition warning." '(and warning (satisfies redefine-warning-p))) -(defun wrong-argument-count-p (warning) - "True if WARNING is about a function call with a wrong number of arguments." - #+sbcl (when (typep warning '(and warning simple-condition)) - (let ((control (format-control-string-or-nil warning))) - (and (search "The function ~S is called" control) - (search "but wants exactly" control))))) - -(deftype wrong-argument-count () - "Type of warning about calling a function with wrong argument count." - '(and warning (satisfies wrong-argument-count-p))) - (defun optional-and-key-p (warning) "Is WARNING a bad style warning about &optional and &key present in the same lambda list?" (when (typep warning 'simple-condition) @@ -235,14 +127,6 @@ This returns two values: a boolean and a name symbol of the function." #+sbcl 'sb-kernel:&optional-and-&key-in-lambda-list #-sbcl '(and warning (satisfies optional-and-key-p))) -(defun deleted-code-p (warning) - "Is WARNING a deleted/unreachable code warning?" - #+sbcl (typep warning 'sb-c::code-deletion-note)) - -(deftype deleted-code () - "Type of a warning about deleted or unreachable code." - '(and warning (satisfies deleted-code-p))) - (defun type-style-warning-p (warning) "Is WARNING a warning about wrong argument type?" #+sbcl (typep warning 'sb-c::type-style-warning)) @@ -259,64 +143,12 @@ This returns two values: a boolean and a name symbol of the function." "Warning about type incompatibility compile time." '(and warning (satisfies type-conflict-p))) -(defun complex-lexical-environment-p (warning) - "Is WARNING a warning about a too complex lexical environment?" - #+sbcl (typep warning 'sb-kernel:lexical-environment-too-complex)) - -(deftype complex-lexical-environment () - "Warning about a too complex lexical environment." - '(and warning (satisfies complex-lexical-environment-p))) - -(defun implicit-generic-p (warning) - "Is this a style WARNING about missing generic definition?" - #+sbcl (typep warning 'sb-ext:implicit-generic-function-warning)) - -(deftype implicit-generic () - "Type of style warning about missing generic function declaration." - '(and warning (satisfies implicit-generic-p))) - -(defun show-notes (note) - "Shows compiler NOTE that is turned off by default." - #+sbcl - (when (typep note 'sb-ext:compiler-note) - :show)) - -(defun stack-allocate-note-p (note) - "True for a stack allocation failure NOTE." - (declare (ignorable note)) - #+sbcl - (when (typep note 'sb-ext:compiler-note) - (let ((control (format-control-string-or-nil note))) - (and (or (search "could" control) (search "can" control)) - (search "not stack allocate" control))))) - -;;; -;;; Stack allocation aka. dynamic-extent. -;;; -;;; The three symbols below are subtly different when used as a warning handler: -;;; - FAIL-STACK-ALLOCATE-NOTES - will fail if the notes show up. -;;; - STACK-ALLOCATE-NOTE - will ignore the notes. -;;; -;;; FAIL-STACK-ALLOCATE-NOTES is installed by default in BAZEL:MAIN. -;;; Use nowarn = ["stack-allocate-note"] to override. -;;; -(deftype stack-allocate-note () - "Type of a condition STACK-ALLOCATE-NOTE for stack allocation failures." - '(and - #+sbcl sb-ext:compiler-note - #-sbcl condition - (satisfies stack-allocate-note-p))) - -(defun fail-stack-allocate-notes (note) - "Fail on compiler NOTE about stack allocation failures." - (when (stack-allocate-note-p note) - :fail)) - (defun uninteresting-condition-p (condition) "A test for an uninteresting CONDITION to be muffled including compiler notes. The conditions muffled here are the minimal/uncontroversial set." #+sbcl (typep condition '(or sb-kernel:redefinition-with-defmacro + sb-kernel:parse-unknown-type sb-kernel:uninteresting-redefinition sb-int:slot-initform-type-style-warning sb-ext:compiler-note @@ -325,34 +157,3 @@ The conditions muffled here are the minimal/uncontroversial set." (deftype uninteresting-condition () "Type of the least interesting compiler warnings and notes." '(and condition (satisfies uninteresting-condition-p))) - -(defun inline-expansion-limit-p (note) - "True if NOTE is an inline expansion limit note." - #+sbcl - (and (typep note 'sb-int:simple-compiler-note) - (let ((control (format-control-string-or-nil note))) - (search "*INLINE-EXPANSION-LIMIT*" control)))) - -(deftype inline-expansion-limit () - "A note of inline-expansion-limit reached." - `(and #+sbcl sb-int:simple-compiler-note - #-sbcl condition - (satisfies inline-expansion-limit-p))) - -(defun fail-inline-expansion-limit (note) - "Fail if the inline expansion limit is exceeded." - (when (typep note 'inline-expansion-limit) - :fail)) - -(defun deprecation-condition-p (c) - "True if C is a condition informing about deprecated features." - (typecase c - #+sbcl - (sb-ext:deprecation-condition t) - ((and warning simple-condition) - (search "deprecated" (format-control-string-or-nil c) - :test #'char-equal)))) - -(deftype deprecation () - "Type of warning about deprecated code." - '(and warning (satisfies deprecation-condition-p)))