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)))