Compare commits
32 commits
corpus/por
...
main
| Author | SHA1 | Date | |
|---|---|---|---|
| 0598f8e7c5 | |||
|
|
855fbc4794 | ||
|
|
6c88198115 | ||
|
|
e297a74501 | ||
|
|
c8167e1c05 | ||
|
|
bff1c288b0 | ||
|
|
94d3bcca20 | ||
|
|
79002526bb | ||
|
|
7167af4830 | ||
|
|
a3e2365217 | ||
|
|
773e647b4a | ||
|
|
dbc5afac32 | ||
|
|
403c3f302f | ||
|
|
1ed9656a0c | ||
|
|
f9fcbc37fd | ||
|
|
4398e2cf6c | ||
|
|
5467c1d98d | ||
|
|
dbc4298c0a | ||
|
|
af12f77dcd | ||
|
|
225073a11b | ||
|
|
9382c67e48 | ||
|
|
24c2280246 | ||
|
|
0afd2095e3 | ||
|
|
c63a18aae1 | ||
|
|
80f3206a6e | ||
|
|
7add315394 | ||
|
|
5ca7437826 | ||
|
|
a67dbdb93d | ||
|
|
ab10e68218 | ||
|
|
b2aa757af2 | ||
|
|
58ef0c8fa1 | ||
|
|
7b4369145d |
38 changed files with 1540 additions and 639 deletions
93
.github/workflows/release.yml
vendored
93
.github/workflows/release.yml
vendored
|
|
@ -12,6 +12,7 @@ on:
|
||||||
push:
|
push:
|
||||||
tags:
|
tags:
|
||||||
- 'v*'
|
- 'v*'
|
||||||
|
workflow_dispatch: {} # dry-run the build matrix without tagging
|
||||||
|
|
||||||
permissions:
|
permissions:
|
||||||
contents: write # create/update the GitHub Release and upload assets
|
contents: write # create/update the GitHub Release and upload assets
|
||||||
|
|
@ -26,10 +27,18 @@ jobs:
|
||||||
include:
|
include:
|
||||||
- os: ubuntu-latest
|
- os: ubuntu-latest
|
||||||
target: x86_64-linux
|
target: x86_64-linux
|
||||||
|
shell: bash
|
||||||
# No x86_64-macos: GitHub is retiring the macos-13 Intel runner (jobs
|
# No x86_64-macos: GitHub is retiring the macos-13 Intel runner (jobs
|
||||||
# queue forever). Intel Macs build from source. macos-14 is arm64.
|
# queue forever). Intel Macs build from source. macos-14 is arm64.
|
||||||
- os: macos-14
|
- os: macos-14
|
||||||
target: aarch64-macos
|
target: aarch64-macos
|
||||||
|
shell: bash
|
||||||
|
- os: windows-latest
|
||||||
|
target: x86_64-windows
|
||||||
|
shell: msys2 {0}
|
||||||
|
defaults:
|
||||||
|
run:
|
||||||
|
shell: ${{ matrix.shell }}
|
||||||
steps:
|
steps:
|
||||||
- uses: actions/checkout@v5
|
- uses: actions/checkout@v5
|
||||||
with:
|
with:
|
||||||
|
|
@ -78,6 +87,65 @@ jobs:
|
||||||
if: runner.os == 'macOS'
|
if: runner.os == 'macOS'
|
||||||
run: brew install chezscheme lz4
|
run: brew install chezscheme lz4
|
||||||
|
|
||||||
|
# --- Windows: MSYS2/MinGW-w64 toolchain + Chez built from source (ta6nt).
|
||||||
|
# The whole job runs in the msys2 shell so cc/xxd/paths behave; the
|
||||||
|
# produced joltc.exe is a plain Windows binary (no MSYS runtime dep). ---
|
||||||
|
- name: Set up MSYS2 (Windows)
|
||||||
|
if: runner.os == 'Windows'
|
||||||
|
uses: msys2/setup-msys2@v2
|
||||||
|
with:
|
||||||
|
msystem: MINGW64
|
||||||
|
update: false
|
||||||
|
# inherit the runner PATH so GITHUB_PATH additions (the chez wrapper
|
||||||
|
# dir) are visible inside the msys2 shell
|
||||||
|
path-type: inherit
|
||||||
|
install: >-
|
||||||
|
git make vim unzip zip
|
||||||
|
mingw-w64-x86_64-gcc
|
||||||
|
mingw-w64-x86_64-lz4
|
||||||
|
mingw-w64-x86_64-zlib
|
||||||
|
mingw-w64-x86_64-ntldd
|
||||||
|
|
||||||
|
- name: Cache Chez Scheme (Windows)
|
||||||
|
if: runner.os == 'Windows'
|
||||||
|
id: cache-chez-win
|
||||||
|
uses: actions/cache@v4
|
||||||
|
with:
|
||||||
|
path: chez-install
|
||||||
|
key: chez-${{ runner.os }}-v10.4.1-mingw64
|
||||||
|
|
||||||
|
- name: Build Chez Scheme from source (Windows)
|
||||||
|
if: runner.os == 'Windows' && steps.cache-chez-win.outputs.cache-hit != 'true'
|
||||||
|
run: |
|
||||||
|
git clone --depth 1 --branch v10.4.1 https://github.com/cisco/ChezScheme.git /tmp/chez-src
|
||||||
|
cd /tmp/chez-src
|
||||||
|
./configure --threads
|
||||||
|
make -j"$(nproc)"
|
||||||
|
# `make install` drives the unix installsh through cmd and dies; the
|
||||||
|
# build tree has everything — assemble the layout by hand. Boot files
|
||||||
|
# sit next to scheme.exe (that's where the Windows kernel looks).
|
||||||
|
inst="$GITHUB_WORKSPACE/chez-install"
|
||||||
|
mkdir -p "$inst/bin" "$inst/csv"
|
||||||
|
cp ta6nt/bin/ta6nt/*.exe "$inst/bin/"
|
||||||
|
cp ta6nt/bin/ta6nt/*.dll "$inst/bin/" 2>/dev/null || true
|
||||||
|
cp ta6nt/boot/ta6nt/petite.boot ta6nt/boot/ta6nt/scheme.boot "$inst/bin/"
|
||||||
|
cp ta6nt/boot/ta6nt/petite.boot ta6nt/boot/ta6nt/scheme.boot "$inst/csv/"
|
||||||
|
cp ta6nt/boot/ta6nt/scheme.h "$inst/csv/"
|
||||||
|
cp ta6nt/boot/ta6nt/equates.h "$inst/csv/" 2>/dev/null || true
|
||||||
|
cp ta6nt/boot/ta6nt/libkernel.a "$inst/csv/" || { echo "libkernel.a not found:"; find ta6nt -name "*.a" -o -name "kernel*"; exit 1; }
|
||||||
|
|
||||||
|
- name: Put chez on PATH (Windows)
|
||||||
|
if: runner.os == 'Windows'
|
||||||
|
run: |
|
||||||
|
bindir="$GITHUB_WORKSPACE/chez-install/bin"
|
||||||
|
{ echo '#!/bin/sh'; echo "exec \"$bindir/scheme.exe\" \"\$@\""; } > "$bindir/chez"
|
||||||
|
chmod +x "$bindir/chez"
|
||||||
|
echo "$bindir" >> "$GITHUB_PATH"
|
||||||
|
echo "JOLT_CHEZ_CSV=$GITHUB_WORKSPACE/chez-install/csv" >> "$GITHUB_ENV"
|
||||||
|
# cc is the build's compiler name; alias it to mingw gcc
|
||||||
|
{ echo '#!/bin/sh'; echo 'exec gcc "$@"'; } > "$bindir/cc"
|
||||||
|
chmod +x "$bindir/cc"
|
||||||
|
|
||||||
- name: Show Chez version
|
- name: Show Chez version
|
||||||
run: chez --version
|
run: chez --version
|
||||||
|
|
||||||
|
|
@ -86,6 +154,19 @@ jobs:
|
||||||
# dev-machine check — see jolt-8479). `make joltc-release`, not `make joltc`.
|
# dev-machine check — see jolt-8479). `make joltc-release`, not `make joltc`.
|
||||||
- name: Build joltc (release)
|
- name: Build joltc (release)
|
||||||
run: make joltc-release
|
run: make joltc-release
|
||||||
|
env:
|
||||||
|
# Bake the release tag into the binary (build-joltc falls back to
|
||||||
|
# `git describe` when this is empty, e.g. a workflow_dispatch dry run).
|
||||||
|
JOLT_VERSION: ${{ startsWith(github.ref, 'refs/tags/') && github.ref_name || '' }}
|
||||||
|
|
||||||
|
- name: Inspect the binary (Windows)
|
||||||
|
if: runner.os == 'Windows'
|
||||||
|
run: |
|
||||||
|
set +e
|
||||||
|
ls -la target/release/
|
||||||
|
ntldd target/release/joltc.exe 2>&1 | head -20
|
||||||
|
./target/release/joltc.exe -e '(+ 1 2)'
|
||||||
|
echo "exit=$?"
|
||||||
|
|
||||||
# Sanity: the built binary runs (no Chez needed) and self-reports a value.
|
# Sanity: the built binary runs (no Chez needed) and self-reports a value.
|
||||||
- name: Smoke the binary
|
- name: Smoke the binary
|
||||||
|
|
@ -132,16 +213,24 @@ jobs:
|
||||||
ver="${GITHUB_REF_NAME}"
|
ver="${GITHUB_REF_NAME}"
|
||||||
name="joltc-${ver}-${{ matrix.target }}"
|
name="joltc-${ver}-${{ matrix.target }}"
|
||||||
mkdir -p "dist/${name}"
|
mkdir -p "dist/${name}"
|
||||||
cp target/release/joltc "dist/${name}/joltc"
|
|
||||||
cp README.md LICENSE "dist/${name}/"
|
cp README.md LICENSE "dist/${name}/"
|
||||||
|
if [ "${{ runner.os }}" = "Windows" ]; then
|
||||||
|
cp target/release/joltc.exe "dist/${name}/joltc.exe"
|
||||||
|
( cd dist && zip -r "${name}.zip" "${name}" && sha256sum "${name}.zip" > "${name}.zip.sha256" )
|
||||||
|
else
|
||||||
|
cp target/release/joltc "dist/${name}/joltc"
|
||||||
tar -C dist -czf "dist/${name}.tar.gz" "${name}"
|
tar -C dist -czf "dist/${name}.tar.gz" "${name}"
|
||||||
( cd dist && shasum -a 256 "${name}.tar.gz" > "${name}.tar.gz.sha256" )
|
( cd dist && shasum -a 256 "${name}.tar.gz" > "${name}.tar.gz.sha256" )
|
||||||
|
fi
|
||||||
ls -la dist
|
ls -la dist
|
||||||
|
|
||||||
- name: Upload to the GitHub Release
|
- name: Upload to the GitHub Release
|
||||||
|
if: startsWith(github.ref, 'refs/tags/')
|
||||||
uses: softprops/action-gh-release@v2
|
uses: softprops/action-gh-release@v2
|
||||||
with:
|
with:
|
||||||
files: |
|
files: |
|
||||||
dist/*.tar.gz
|
dist/*.tar.gz
|
||||||
dist/*.tar.gz.sha256
|
dist/*.tar.gz.sha256
|
||||||
fail_on_unmatched_files: true
|
dist/*.zip
|
||||||
|
dist/*.zip.sha256
|
||||||
|
fail_on_unmatched_files: false
|
||||||
|
|
|
||||||
6
.github/workflows/tests.yml
vendored
6
.github/workflows/tests.yml
vendored
|
|
@ -56,7 +56,11 @@ jobs:
|
||||||
- name: Install JDK + Clojure (certify oracle)
|
- name: Install JDK + Clojure (certify oracle)
|
||||||
run: |
|
run: |
|
||||||
sudo apt-get install -y default-jdk rlwrap
|
sudo apt-get install -y default-jdk rlwrap
|
||||||
curl -L -O https://github.com/clojure/brew-install/releases/latest/download/linux-install.sh
|
# --retry + --fail so a transient CDN error retries instead of handing
|
||||||
|
# bash an HTML error page (a 2min timeout page flaked a run)
|
||||||
|
curl --fail --retry 5 --retry-delay 10 --retry-all-errors -L -O \
|
||||||
|
https://github.com/clojure/brew-install/releases/latest/download/linux-install.sh
|
||||||
|
head -1 linux-install.sh | grep -q '^#!' || { echo "installer download corrupt"; cat linux-install.sh | head -5; exit 1; }
|
||||||
sudo bash linux-install.sh
|
sudo bash linux-install.sh
|
||||||
clojure --version
|
clojure --version
|
||||||
|
|
||||||
|
|
|
||||||
11
Makefile
11
Makefile
|
|
@ -4,18 +4,23 @@
|
||||||
# build step. `make test` is the full gate. `make remint` rebuilds the seed after a
|
# build step. `make test` is the full gate. `make remint` rebuilds the seed after a
|
||||||
# source change.
|
# source change.
|
||||||
|
|
||||||
.PHONY: test ci values corpus unit smoke buildsmoke staticnativesmoke selfhost sci cts certify ffi transient infer wp devirt fieldread numwp fieldnum protoret narrow directlink numeric inline shakesmoke remint joltc joltc-release joltc-debug joltcsmoke
|
.PHONY: test ci values corpus unit smoke buildsmoke staticnativesmoke selfhost sci cts certify ffi transient infer wp devirt fieldread numwp fieldnum protoret narrow directlink numeric inline shakesmoke remint joltc joltc-release joltc-debug joltcsmoke submodules
|
||||||
|
|
||||||
|
# Every target needs the vendored submodules; fail with the fix, not a load error.
|
||||||
|
submodules:
|
||||||
|
@test -f vendor/irregex/irregex.scm || { \
|
||||||
|
echo "vendor submodules missing; run: git submodule update --init --recursive"; exit 1; }
|
||||||
|
|
||||||
# Full gate (dev machine). Includes the self-host byte-fixpoint, which only holds
|
# Full gate (dev machine). Includes the self-host byte-fixpoint, which only holds
|
||||||
# on the same Chez that minted the seed.
|
# on the same Chez that minted the seed.
|
||||||
test: selfhost ci
|
test: submodules selfhost ci
|
||||||
@echo "OK: all gates passed"
|
@echo "OK: all gates passed"
|
||||||
|
|
||||||
# CI gate: behavior only. The checked-in seed is a minted artifact (like a
|
# CI gate: behavior only. The checked-in seed is a minted artifact (like a
|
||||||
# lockfile) — it RUNS correctly on any Chez, but `selfhost` rebuilds it and a
|
# lockfile) — it RUNS correctly on any Chez, but `selfhost` rebuilds it and a
|
||||||
# different Chez version may emit byte-different (gensym/order) output, so the
|
# different Chez version may emit byte-different (gensym/order) output, so the
|
||||||
# byte-fixpoint is a dev-machine check, not a CI one (jolt-8479).
|
# byte-fixpoint is a dev-machine check, not a CI one (jolt-8479).
|
||||||
ci: values corpus unit smoke buildsmoke staticnativesmoke sci cts ffi transient infer wp devirt fieldread numwp fieldnum protoret narrow directlink numeric inline certify
|
ci: submodules values corpus unit smoke buildsmoke staticnativesmoke sci cts ffi transient infer wp devirt fieldread numwp fieldnum protoret narrow directlink numeric inline certify
|
||||||
@echo "OK: CI gates passed"
|
@echo "OK: CI gates passed"
|
||||||
|
|
||||||
# Self-host fixpoint: bootstrap.ss rebuild == checked-in seed.
|
# Self-host fixpoint: bootstrap.ss rebuild == checked-in seed.
|
||||||
|
|
|
||||||
20
README.md
20
README.md
|
|
@ -9,8 +9,12 @@ runs it on Chez. The compiler is self-hosted: it is written in Clojure
|
||||||
|
|
||||||
## Install
|
## Install
|
||||||
|
|
||||||
Grab the self-contained `joltc` binary (Linux/macOS) — it bundles the runtime,
|
Grab the self-contained `joltc` binary (Linux/macOS/Windows) — it bundles the
|
||||||
compiler, and standard library, so there is nothing else to install.
|
runtime, compiler, and standard library, so there is nothing else to install.
|
||||||
|
Download the binary archive for your platform from the
|
||||||
|
[releases page](https://github.com/jolt-lang/jolt/releases) (`joltc-<ver>-<platform>.tar.gz`,
|
||||||
|
or the `.zip` on Windows). The "Source code" archives GitHub attaches to every
|
||||||
|
release are not binaries — see [Build](#build) before using one.
|
||||||
|
|
||||||
With Homebrew:
|
With Homebrew:
|
||||||
|
|
||||||
|
|
@ -45,6 +49,18 @@ cd jolt
|
||||||
bin/joltc -e '(+ 1 2)' # => 3
|
bin/joltc -e '(+ 1 2)' # => 3
|
||||||
```
|
```
|
||||||
|
|
||||||
|
The `--recurse-submodules` matters: jolt vendors its regex engine and test
|
||||||
|
suites as git submodules. In a checkout that's missing them (a plain
|
||||||
|
`git clone`, or after pulling a commit that adds one), fetch them with:
|
||||||
|
|
||||||
|
```bash
|
||||||
|
git submodule update --init --recursive
|
||||||
|
```
|
||||||
|
|
||||||
|
Note that GitHub's auto-generated "Source code (zip/tar.gz)" archives on the
|
||||||
|
releases page do **not** contain submodules, so they can't run or build —
|
||||||
|
clone the repo instead (or grab a prebuilt binary from the same page).
|
||||||
|
|
||||||
After changing a compiler source — the reader (`host/chez/reader.ss`), the
|
After changing a compiler source — the reader (`host/chez/reader.ss`), the
|
||||||
analyzer/IR/backend (`jolt-core/jolt/*.clj`), or the `clojure.core` overlay
|
analyzer/IR/backend (`jolt-core/jolt/*.clj`), or the `clojure.core` overlay
|
||||||
(`jolt-core/clojure/core/*.clj`) — re-mint the seed:
|
(`jolt-core/clojure/core/*.clj`) — re-mint the seed:
|
||||||
|
|
|
||||||
25
bin/joltc
25
bin/joltc
|
|
@ -14,5 +14,28 @@
|
||||||
# JOLT_PWD.
|
# JOLT_PWD.
|
||||||
root="$(CDPATH= cd -- "$(dirname -- "$0")/.." && pwd)"
|
root="$(CDPATH= cd -- "$(dirname -- "$0")/.." && pwd)"
|
||||||
export JOLT_PWD="${JOLT_PWD:-$PWD}"
|
export JOLT_PWD="${JOLT_PWD:-$PWD}"
|
||||||
|
|
||||||
|
# Identify the Chez Scheme executable
|
||||||
|
while read -r CHEZ
|
||||||
|
do
|
||||||
|
if [ `which ${CHEZ}` ]
|
||||||
|
then
|
||||||
|
break;
|
||||||
|
fi
|
||||||
|
done <<EOF
|
||||||
|
chez
|
||||||
|
chezscheme
|
||||||
|
EOF
|
||||||
|
|
||||||
|
# If we failed to find one, whinge and exit.
|
||||||
|
if [ ! `which ${CHEZ}` ]
|
||||||
|
then
|
||||||
|
echo "No valid Chez Scheme executable found: please install Chez Scheme."
|
||||||
|
exit 1
|
||||||
|
fi
|
||||||
|
|
||||||
|
# Version for --version / banners: git describe of this checkout, else "dev".
|
||||||
|
export JOLT_VERSION="${JOLT_VERSION:-$(git -C "$root" describe --tags --always --dirty 2>/dev/null || echo dev)}"
|
||||||
cd "$root" || exit 1
|
cd "$root" || exit 1
|
||||||
exec chez --script host/chez/cli.ss "$@"
|
exec ${CHEZ} --script host/chez/cli.ss "$@"
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -182,6 +182,30 @@ a root, transitively.
|
||||||
- Source only; compiled `.class` files in a git dep are ignored.
|
- Source only; compiled `.class` files in a git dep are ignored.
|
||||||
- git `:git/sha` must be a full SHA (`git fetch` can't resolve a short one).
|
- git `:git/sha` must be a full SHA (`git fetch` can't resolve a short one).
|
||||||
|
|
||||||
|
## Stack traces
|
||||||
|
|
||||||
|
An uncaught error prints the message, the top-level source location, and — when
|
||||||
|
frames are available — a `trace:` backtrace. In an AOT `jolt build --direct-link`
|
||||||
|
binary the frames map to `ns/name (file:line)`; on the runtime eval path they are
|
||||||
|
the surviving fn names. Tail-call optimization erases tail-called frames, so the
|
||||||
|
default trace shows only the non-tail spine.
|
||||||
|
|
||||||
|
A fuller **tail-frame history** recovers the frames TCO erases: each compiled fn
|
||||||
|
records itself on entry into a bounded ring-of-rings buffer, so the trace shows
|
||||||
|
TCO-elided frames (including the immediate error site) while a tight tail loop
|
||||||
|
stays bounded and its non-tail caller context is preserved.
|
||||||
|
|
||||||
|
It is **on by default in REPL-driven development** — a `repl` or nREPL session
|
||||||
|
turns it on, so an error in code you evaluate or reload shows a tail-frame trace
|
||||||
|
with no setup. Because the recording is baked in at compile time, only code
|
||||||
|
compiled while a session is live is traced; reload a namespace to trace code that
|
||||||
|
was already loaded (e.g. an app's initial `-M:run` load before its nREPL started).
|
||||||
|
|
||||||
|
Elsewhere it is off (a small per-call cost, and never emitted into a `jolt build`
|
||||||
|
binary). Override with the environment: `JOLT_TRACE=1` forces it on for a whole
|
||||||
|
run — including a plain `-M:run`, so the app's own load is traced — and
|
||||||
|
`JOLT_TRACE=0` forces it off, even in a REPL/nREPL session.
|
||||||
|
|
||||||
## Conformance
|
## Conformance
|
||||||
|
|
||||||
The known-working libraries (see [libraries.md](libraries.md)) and the
|
The known-working libraries (see [libraries.md](libraries.md)) and the
|
||||||
|
|
|
||||||
|
|
@ -46,6 +46,15 @@
|
||||||
(unless (or jb-release? (string=? jb-profile "debug"))
|
(unless (or jb-release? (string=? jb-profile "debug"))
|
||||||
(error 'build-joltc "profile must be \"release\" or \"debug\"" jb-profile))
|
(error 'build-joltc "profile must be \"release\" or \"debug\"" jb-profile))
|
||||||
|
|
||||||
|
;; Version baked into the binary's saved heap. Prefer $JOLT_VERSION (CI sets it to
|
||||||
|
;; the release tag); else derive it from git in this checkout; else "dev".
|
||||||
|
(define jb-version
|
||||||
|
(let ((env (getenv "JOLT_VERSION")))
|
||||||
|
(if (and env (> (string-length env) 0))
|
||||||
|
env
|
||||||
|
(let ((s (bld-sh-capture "git describe --tags --always --dirty 2>/dev/null")))
|
||||||
|
(if (> (string-length s) 0) s "dev")))))
|
||||||
|
|
||||||
(define jb-build (string-append jb-out ".build"))
|
(define jb-build (string-append jb-out ".build"))
|
||||||
(bld-check-toolchain)
|
(bld-check-toolchain)
|
||||||
(bld-system (string-append "mkdir -p '" (path-parent jb-out) "' '" jb-build "'"))
|
(bld-system (string-append "mkdir -p '" (path-parent jb-out) "' '" jb-build "'"))
|
||||||
|
|
@ -136,11 +145,10 @@
|
||||||
(scheme-start
|
(scheme-start
|
||||||
(lambda args
|
(lambda args
|
||||||
(set-source-roots! (list \"jolt-core\" \"stdlib\"))
|
(set-source-roots! (list \"jolt-core\" \"stdlib\"))
|
||||||
(guard (v (#t (jolt-report-throwable v (current-error-port))
|
;; JOLT_TRACE at RUNTIME (the env is unset at heap-build), before any app ns
|
||||||
(let ((bt (jolt-backtrace-string v)))
|
;; compiles, so a `-M:run` traces the app's own code.
|
||||||
(when bt (display \" trace:\\n\" (current-error-port))
|
(jolt-trace-init-from-env!)
|
||||||
(display bt (current-error-port))))
|
(guard (v (#t (jolt-report-throwable v (current-error-port)) (exit 1)))
|
||||||
(exit 1)))
|
|
||||||
(cond
|
(cond
|
||||||
((and (= (length args) 2) (string=? (car args) \"-e\"))
|
((and (= (length args) 2) (string=? (car args) \"-e\"))
|
||||||
(let ((result (jolt-final-str
|
(let ((result (jolt-final-str
|
||||||
|
|
@ -164,6 +172,10 @@
|
||||||
(jb-emit-runtime-embeds out)
|
(jb-emit-runtime-embeds out)
|
||||||
(put-string out "\n;; === embedded jolt-core + stdlib source ===\n")
|
(put-string out "\n;; === embedded jolt-core + stdlib source ===\n")
|
||||||
(jb-emit-source-embeds out)
|
(jb-emit-source-embeds out)
|
||||||
|
;; Bake the version into the saved heap (runs at heap-build; loader.ss defined
|
||||||
|
;; jolt-baked-version above, so this set! resolves).
|
||||||
|
(put-string out (string-append "\n;; === baked version ===\n(set! jolt-baked-version "
|
||||||
|
(ei-str-lit jb-version) ")\n"))
|
||||||
(put-string out "\n;; === joltc launcher ===\n")
|
(put-string out "\n;; === joltc launcher ===\n")
|
||||||
(jb-emit-launcher out)
|
(jb-emit-launcher out)
|
||||||
(close-port out))
|
(close-port out))
|
||||||
|
|
@ -245,6 +257,8 @@
|
||||||
;; table so `build` can foreign-entry them to spill the bundled Chez boots. On
|
;; table so `build` can foreign-entry them to spill the bundled Chez boots. On
|
||||||
;; Linux dlsym can't see executable symbols otherwise (macOS exports them anyway).
|
;; Linux dlsym can't see executable symbols otherwise (macOS exports them anyway).
|
||||||
(bld-system (string-append
|
(bld-system (string-append
|
||||||
"cc -O2 -rdynamic -I'" bld-csv-dir "' -I'" jb-build "' '" jb-main-c "' '"
|
;; the embedded jolt_* arrays must be foreign-entry-visible at runtime:
|
||||||
|
;; -rdynamic on ELF; on Windows an exe needs an export table (GetProcAddress).
|
||||||
|
"cc -O2 " (if bld-nt? "-Wl,--export-all-symbols " "-rdynamic ") "-I'" bld-csv-dir "' -I'" jb-build "' '" jb-main-c "' '"
|
||||||
bld-csv-dir "/libkernel.a' -o '" jb-out "' " (bld-link-libs)))
|
bld-csv-dir "/libkernel.a' -o '" jb-out "' " (bld-link-libs)))
|
||||||
(display (string-append "build-joltc: wrote " jb-out "\n"))
|
(display (string-append "build-joltc: wrote " jb-out "\n"))
|
||||||
|
|
|
||||||
|
|
@ -94,6 +94,28 @@ for frame in 'app.util/deep-boom' 'app.util/mid-boom' 'app.core/-main'; do
|
||||||
exit 1
|
exit 1
|
||||||
fi
|
fi
|
||||||
done
|
done
|
||||||
|
# A built binary runs -main with *ns* = user, like clojure.main — so a runtime
|
||||||
|
# resolve of an aliased symbol is nil (the alias lives in the entry ns, not user),
|
||||||
|
# matching the JVM and interpreted joltc rather than the entry ns's alias table. A
|
||||||
|
# separate app: `resolve` defeats tree-shaking, so keep it out of the shake test's
|
||||||
|
# app above.
|
||||||
|
nsp="$(dirname "$out")/nsparity"
|
||||||
|
mkdir -p "$nsp/src/nsp"
|
||||||
|
printf '{:paths ["src"]}\n' > "$nsp/deps.edn"
|
||||||
|
printf '(ns nsp.lib)\n(defn thing [] 1)\n' > "$nsp/src/nsp/lib.clj"
|
||||||
|
printf '(ns nsp.main (:require [nsp.lib :as l]))\n(defn -main [& _]\n (println "ns:" (str *ns*))\n (println "resolve:" (pr-str (resolve (quote l/thing))))\n (println "ns-resolve:" (pr-str (ns-resolve (quote nsp.lib) (quote thing)))))\n' > "$nsp/src/nsp/main.clj"
|
||||||
|
nspout="$(dirname "$out")/nsparity-bin"
|
||||||
|
if ! JOLT_PWD="$nsp" bin/joltc build -m nsp.main -o "$nspout" >/dev/null 2>&1; then
|
||||||
|
echo " FAIL: jolt build of the ns-parity app exited non-zero"; exit 1
|
||||||
|
fi
|
||||||
|
nsp_out="$(cd / && "$nspout" 2>&1)"
|
||||||
|
if ! printf '%s' "$nsp_out" | grep -q 'ns: user' \
|
||||||
|
|| ! printf '%s' "$nsp_out" | grep -q '^resolve: nil' \
|
||||||
|
|| ! printf '%s' "$nsp_out" | grep -q "ns-resolve: #'nsp.lib/thing"; then
|
||||||
|
echo " FAIL: built binary -main ns parity — want 'ns: user', 'resolve: nil', ns-resolve found"
|
||||||
|
echo "--- got ----"; echo "$nsp_out"
|
||||||
|
exit 1
|
||||||
|
fi
|
||||||
# Tree-shaking (opt-in): same result, and an unreachable def (the `twice` macro,
|
# Tree-shaking (opt-in): same result, and an unreachable def (the `twice` macro,
|
||||||
# expanded at AOT and never called at runtime) is dropped.
|
# expanded at AOT and never called at runtime) is dropped.
|
||||||
if ! JOLT_PWD="$app" bin/joltc build -m app.core -o "$out" --tree-shake >/dev/null 2>&1; then
|
if ! JOLT_PWD="$app" bin/joltc build -m app.core -o "$out" --tree-shake >/dev/null 2>&1; then
|
||||||
|
|
@ -129,4 +151,20 @@ if [ "$got_dr" != "42" ]; then
|
||||||
echo " FAIL: built #code data reader — want 42, got \`$got_dr\`"; exit 1
|
echo " FAIL: built #code data reader — want 42, got \`$got_dr\`"; exit 1
|
||||||
fi
|
fi
|
||||||
|
|
||||||
echo "build smoke: passed (release + optimized + direct-link + tree-shake + compiler+core shake + data-reader)"
|
# A script namespace with no -main (just top-level side effects) must build and
|
||||||
|
# run its top-level forms, then exit cleanly — not crash calling a nil -main.
|
||||||
|
nomain="$(dirname "$out")/nomain"
|
||||||
|
mkdir -p "$nomain/src"
|
||||||
|
printf '{:paths ["src"]}\n' > "$nomain/deps.edn"
|
||||||
|
printf '(ns script)\n(println "no-main script ran")\n' > "$nomain/src/script.clj"
|
||||||
|
nmout="$(dirname "$out")/nomain-bin"
|
||||||
|
if ! JOLT_PWD="$nomain" bin/joltc build -m script -o "$nmout" >/dev/null 2>&1; then
|
||||||
|
echo " FAIL: jolt build of a no-main script exited non-zero"; exit 1
|
||||||
|
fi
|
||||||
|
got_nm="$(cd / && "$nmout" 2>&1)"; rc_nm=$?
|
||||||
|
if [ "$got_nm" != "no-main script ran" ] || [ "$rc_nm" != "0" ]; then
|
||||||
|
echo " FAIL: no-main script binary — want 'no-main script ran' rc 0, got \`$got_nm\` rc $rc_nm"
|
||||||
|
exit 1
|
||||||
|
fi
|
||||||
|
|
||||||
|
echo "build smoke: passed (release + optimized + direct-link + tree-shake + compiler+core shake + data-reader + no-main)"
|
||||||
|
|
|
||||||
|
|
@ -23,7 +23,7 @@
|
||||||
;; --- shell helpers ----------------------------------------------------------
|
;; --- shell helpers ----------------------------------------------------------
|
||||||
;; Run a command, return its stdout as one trimmed string ("" on no output).
|
;; Run a command, return its stdout as one trimmed string ("" on no output).
|
||||||
(define (bld-sh-capture cmd)
|
(define (bld-sh-capture cmd)
|
||||||
(let* ((p (process cmd)) (in (car p)))
|
(let* ((p (process (bld-sh-wrap cmd))) (in (car p)))
|
||||||
(let loop ((acc '()))
|
(let loop ((acc '()))
|
||||||
(let ((l (get-line in)))
|
(let ((l (get-line in)))
|
||||||
(if (eof-object? l)
|
(if (eof-object? l)
|
||||||
|
|
@ -37,7 +37,7 @@
|
||||||
(loop (cons l acc)))))))
|
(loop (cons l acc)))))))
|
||||||
|
|
||||||
(define (bld-system cmd)
|
(define (bld-system cmd)
|
||||||
(let ((rc (system cmd)))
|
(let ((rc (system (bld-sh-wrap cmd))))
|
||||||
(unless (zero? rc)
|
(unless (zero? rc)
|
||||||
(error 'jolt-build (string-append "command failed (" (number->string rc) "): " cmd)))))
|
(error 'jolt-build (string-append "command failed (" (number->string rc) "): " cmd)))))
|
||||||
|
|
||||||
|
|
@ -57,6 +57,24 @@
|
||||||
;; --- toolchain discovery ----------------------------------------------------
|
;; --- toolchain discovery ----------------------------------------------------
|
||||||
(define bld-machine (symbol->string (machine-type)))
|
(define bld-machine (symbol->string (machine-type)))
|
||||||
(define bld-osx? (bld-contains? bld-machine "osx"))
|
(define bld-osx? (bld-contains? bld-machine "osx"))
|
||||||
|
(define bld-nt? (bld-contains? bld-machine "nt"))
|
||||||
|
|
||||||
|
;; Chez's system/process run through cmd.exe on Windows; every build command
|
||||||
|
;; here is written for sh (MSYS2 provides it). On nt, spill the command to a
|
||||||
|
;; script and run `sh <file>` — workspace paths carry no spaces, and the
|
||||||
|
;; script file sidesteps cmd's quoting entirely. Identity elsewhere.
|
||||||
|
(define bld-shell-counter 0)
|
||||||
|
(define (bld-sh-wrap cmd)
|
||||||
|
(if bld-nt?
|
||||||
|
(let* ((tmp (or (getenv "TEMP") (getenv "TMP") "."))
|
||||||
|
(f (begin (set! bld-shell-counter (+ bld-shell-counter 1))
|
||||||
|
(string-append tmp "\\jolt-sh-"
|
||||||
|
(number->string bld-shell-counter) ".sh"))))
|
||||||
|
(let ((p (open-output-file f 'replace)))
|
||||||
|
(put-string p cmd)
|
||||||
|
(close-port p))
|
||||||
|
(string-append "sh " f))
|
||||||
|
cmd))
|
||||||
|
|
||||||
;; The Chez executable, for the isolated compile pass (see build-binary step 4).
|
;; The Chez executable, for the isolated compile pass (see build-binary step 4).
|
||||||
(define bld-chez
|
(define bld-chez
|
||||||
|
|
@ -94,14 +112,21 @@
|
||||||
|
|
||||||
;; Link flags. macOS Homebrew layout for the kernel's lz4/zlib/ncurses deps.
|
;; Link flags. macOS Homebrew layout for the kernel's lz4/zlib/ncurses deps.
|
||||||
(define (bld-link-libs)
|
(define (bld-link-libs)
|
||||||
(if bld-osx?
|
(cond
|
||||||
|
(bld-osx?
|
||||||
(let ((lz4 (bld-sh-capture "brew --prefix lz4 2>/dev/null")))
|
(let ((lz4 (bld-sh-capture "brew --prefix lz4 2>/dev/null")))
|
||||||
(string-append
|
(string-append
|
||||||
(if (> (string-length lz4) 0) (string-append "-L" lz4 "/lib ") "")
|
(if (> (string-length lz4) 0) (string-append "-L" lz4 "/lib ") "")
|
||||||
"-llz4 -lz -lncurses -framework Foundation -liconv -lm"))
|
"-llz4 -lz -lncurses -framework Foundation -liconv -lm")))
|
||||||
|
;; Windows (ta6nt, MinGW-w64 under MSYS2): the Chez kernel pulls in
|
||||||
|
;; compression, winsock, COM/UUID, and the registry.
|
||||||
|
(bld-nt?
|
||||||
|
;; -static: a single-file exe (no libwinpthread/libgcc/lz4 DLL deps) —
|
||||||
|
;; required for a distributable binary and for TLS init consistency.
|
||||||
|
"-static -llz4 -lz -lws2_32 -lrpcrt4 -lole32 -luuid -ladvapi32 -luser32 -lshell32 -lm")
|
||||||
;; Linux: the Chez kernel pulls in compression (lz4/z), the expression
|
;; Linux: the Chez kernel pulls in compression (lz4/z), the expression
|
||||||
;; editor (ncurses + terminfo), threads, dlopen, libuuid, and clock_gettime.
|
;; editor (ncurses + terminfo), threads, dlopen, libuuid, and clock_gettime.
|
||||||
"-llz4 -lz -lncurses -ltinfo -ldl -lm -lpthread -luuid -lrt"))
|
(else "-llz4 -lz -lncurses -ltinfo -ldl -lm -lpthread -luuid -lrt")))
|
||||||
|
|
||||||
;; --- runtime manifest (mirrors host/chez/cli.ss's load order) ---------------
|
;; --- runtime manifest (mirrors host/chez/cli.ss's load order) ---------------
|
||||||
;; A line is either literal Scheme text to inline, or a tag whose emission the build
|
;; A line is either literal Scheme text to inline, or a tag whose emission the build
|
||||||
|
|
@ -411,7 +436,15 @@
|
||||||
;; direct-link?: opt-in closed-world direct-linking (app->app calls bind directly,
|
;; direct-link?: opt-in closed-world direct-linking (app->app calls bind directly,
|
||||||
;; no runtime redefinition). Off by default in every mode — release stays
|
;; no runtime redefinition). Off by default in every mode — release stays
|
||||||
;; dynamically linked.
|
;; dynamically linked.
|
||||||
|
(define (bld-suffix? s suf)
|
||||||
|
(let ((n (string-length s)) (m (string-length suf)))
|
||||||
|
(and (>= n m) (string=? (substring s (- n m) n) suf))))
|
||||||
(define (build-binary entry-ns out-path mode natives embed-dirs ext-roots direct-link? tree-shake?)
|
(define (build-binary entry-ns out-path mode natives embed-dirs ext-roots direct-link? tree-shake?)
|
||||||
|
;; Windows executables carry .exe; normalize here so the append-payload and
|
||||||
|
;; cc paths agree and the shell can run the result.
|
||||||
|
(let ((out-path (if (and bld-nt? (not (bld-suffix? out-path ".exe")))
|
||||||
|
(string-append out-path ".exe")
|
||||||
|
out-path)))
|
||||||
;; The self-contained path (jolt-embedded-bytes "stub/launcher") needs no csv
|
;; The self-contained path (jolt-embedded-bytes "stub/launcher") needs no csv
|
||||||
;; kernel files, no Chez, no cc — only the legacy cc path does.
|
;; kernel files, no Chez, no cc — only the legacy cc path does.
|
||||||
(unless (jolt-embedded-bytes "stub/launcher") (bld-check-toolchain))
|
(unless (jolt-embedded-bytes "stub/launcher") (bld-check-toolchain))
|
||||||
|
|
@ -538,11 +571,23 @@
|
||||||
"))\n"
|
"))\n"
|
||||||
" (list \"jolt-core\" \"stdlib\"))))\n"))
|
" (list \"jolt-core\" \"stdlib\"))))\n"))
|
||||||
(put-string out (string-append
|
(put-string out (string-append
|
||||||
" (let ((mainv (var-deref " (ei-str-lit entry-ns) " \"-main\")))\n"
|
;; Call -main only if the entry namespace defines one;
|
||||||
|
;; a script ns (top-level side effects, no -main) has
|
||||||
|
;; already run its forms at heap build, so invoking a nil
|
||||||
|
;; -main would crash ("nil cannot be cast to IFn") — just
|
||||||
|
;; exit cleanly instead.
|
||||||
|
" (let ((maincell (var-cell-lookup " (ei-str-lit entry-ns) " \"-main\")))\n"
|
||||||
;; render an uncaught throw (+ Clojure backtrace) instead
|
;; render an uncaught throw (+ Clojure backtrace) instead
|
||||||
;; of Chez's opaque dump, then exit non-zero.
|
;; of Chez's opaque dump, then exit non-zero.
|
||||||
" (guard (v (#t (jolt-report-throwable v (current-error-port)) (exit 1)))\n"
|
" (guard (v (#t (jolt-report-throwable v (current-error-port)) (exit 1)))\n"
|
||||||
" (apply jolt-invoke mainv args)))\n"
|
;; Loading the app left the current ns at the entry ns; reset
|
||||||
|
;; it to `user` before -main, matching clojure.main (*ns* is
|
||||||
|
;; `user` when a `-m` -main runs, so a runtime resolve of an
|
||||||
|
;; aliased symbol behaves the same as on the JVM / interpreted
|
||||||
|
;; joltc, not off the entry ns's alias table).
|
||||||
|
" (set-chez-ns! \"user\")\n"
|
||||||
|
" (when (and maincell (var-cell-defined? maincell))\n"
|
||||||
|
" (apply jolt-invoke (var-cell-root maincell) args))))\n"
|
||||||
" (exit 0)))\n"))
|
" (exit 0)))\n"))
|
||||||
(close-port out))
|
(close-port out))
|
||||||
;; 4. compile -> boot -> link. Two paths, chosen by whether this process
|
;; 4. compile -> boot -> link. Two paths, chosen by whether this process
|
||||||
|
|
@ -558,7 +603,7 @@
|
||||||
(build-self-contained entry-ns out-path mode builddir flat-ss flat-so boot
|
(build-self-contained entry-ns out-path mode builddir flat-ss flat-so boot
|
||||||
(bld-native-link-flags natives))
|
(bld-native-link-flags natives))
|
||||||
(build-with-cc entry-ns out-path mode builddir flat-ss flat-so boot boot-h main-c
|
(build-with-cc entry-ns out-path mode builddir flat-ss flat-so boot boot-h main-c
|
||||||
(bld-native-link-flags natives))))))))
|
(bld-native-link-flags natives)))))))))
|
||||||
|
|
||||||
;; --- self-contained link (in-process compile + append the boot to the stub) ---
|
;; --- self-contained link (in-process compile + append the boot to the stub) ---
|
||||||
;; compile-file runs against the DEFAULT interaction environment, so the boot's
|
;; compile-file runs against the DEFAULT interaction environment, so the boot's
|
||||||
|
|
|
||||||
|
|
@ -11,6 +11,26 @@
|
||||||
|
|
||||||
(define cli-args (cdr (command-line))) ; drop the script name
|
(define cli-args (cdr (command-line))) ; drop the script name
|
||||||
|
|
||||||
|
;; Fail early and actionably when the vendored submodules aren't checked out —
|
||||||
|
;; a plain `git clone` or GitHub's auto-generated "Source code" release archive
|
||||||
|
;; lacks them, and the raw failure ("load failed for vendor/irregex/irregex.scm")
|
||||||
|
;; doesn't say how to fix it. (The self-contained joltc binary embeds these and
|
||||||
|
;; never runs this file.)
|
||||||
|
(unless (file-exists? "vendor/irregex/irregex.scm")
|
||||||
|
(display "jolt: vendor submodules are missing (vendor/irregex).
|
||||||
|
" (current-error-port))
|
||||||
|
(display "GitHub's 'Source code' release archives don't include submodules.
|
||||||
|
" (current-error-port))
|
||||||
|
(display "Clone the repo instead:
|
||||||
|
" (current-error-port))
|
||||||
|
(display " git clone --recurse-submodules https://github.com/jolt-lang/jolt.git
|
||||||
|
" (current-error-port))
|
||||||
|
(display "or, in an existing checkout:
|
||||||
|
" (current-error-port))
|
||||||
|
(display " git submodule update --init --recursive
|
||||||
|
" (current-error-port))
|
||||||
|
(exit 1))
|
||||||
|
|
||||||
(load "host/chez/rt.ss")
|
(load "host/chez/rt.ss")
|
||||||
(set-chez-ns! "clojure.core")
|
(set-chez-ns! "clojure.core")
|
||||||
(load "host/chez/seed/prelude.ss")
|
(load "host/chez/seed/prelude.ss")
|
||||||
|
|
@ -46,6 +66,9 @@
|
||||||
(when bt (display " trace:\n" port) (display bt port)))
|
(when bt (display " trace:\n" port) (display bt port)))
|
||||||
(exit 1)))
|
(exit 1)))
|
||||||
|
|
||||||
|
;; JOLT_TRACE opt-in, at runtime (before any app ns compiles) so the app is traced.
|
||||||
|
(jolt-trace-init-from-env!)
|
||||||
|
|
||||||
(guard (v (#t (jolt-report-uncaught v)))
|
(guard (v (#t (jolt-report-uncaught v)))
|
||||||
(cond
|
(cond
|
||||||
;; -e EXPR — evaluate one expression and print it (blank for nil). Wrapped in
|
;; -e EXPR — evaluate one expression and print it (blank for nil). Wrapped in
|
||||||
|
|
|
||||||
|
|
@ -298,8 +298,21 @@
|
||||||
(define empty-pmap-hash (make-pmap empty-hnode 0 #f)) ; hash-order backing (sets)
|
(define empty-pmap-hash (make-pmap empty-hnode 0 #f)) ; hash-order backing (sets)
|
||||||
(define pmap-absent (list 'absent)) ; unique missing-key sentinel
|
(define pmap-absent (list 'absent)) ; unique missing-key sentinel
|
||||||
;; PersistentArrayMap threshold: assoc of a new key promotes to hash mode once the
|
;; PersistentArrayMap threshold: assoc of a new key promotes to hash mode once the
|
||||||
;; map already holds 8 entries (array.length >= 16 in the reference).
|
;; map already holds 8 entries (array.length >= 16 in the reference). Clojure 1.13
|
||||||
|
;; raised the limit to 64 for maps whose keys are ALL keywords (the common
|
||||||
|
;; keyword-map case); mixed-key maps still cap at 8.
|
||||||
(define array-map-limit 8)
|
(define array-map-limit 8)
|
||||||
|
(define array-map-limit-kw 64)
|
||||||
|
(define (all-keywords? ks)
|
||||||
|
(or (null? ks) (and (keyword? (car ks)) (all-keywords? (cdr ks)))))
|
||||||
|
;; Should a map of `cnt` entries with insertion order `ord` stay in array mode
|
||||||
|
;; when key `k` is added? Under 8 always; a keyword-only map (existing keys + the
|
||||||
|
;; new key all keywords) grows to 64; otherwise it caps at 8.
|
||||||
|
(define (pmap-array-keep? cnt ord k)
|
||||||
|
(cond ((fx<? cnt array-map-limit) #t)
|
||||||
|
((fx>=? cnt array-map-limit-kw) #f)
|
||||||
|
((and (keyword? k) (all-keywords? ord)) #t)
|
||||||
|
(else #f)))
|
||||||
(define (append-key ord k) (append ord (list k)))
|
(define (append-key ord k) (append ord (list k)))
|
||||||
(define (remove-key ord k) (let loop ((o ord)) (cond ((null? o) '()) ((jolt= (car o) k) (cdr o)) (else (cons (car o) (loop (cdr o)))))))
|
(define (remove-key ord k) (let loop ((o ord)) (cond ((null? o) '()) ((jolt= (car o) k) (cdr o)) (else (cons (car o) (loop (cdr o)))))))
|
||||||
|
|
||||||
|
|
@ -310,7 +323,7 @@
|
||||||
(let* ((added (box #f)) (r (node-assoc (pmap-root m) 0 (key-hash k) k v added))
|
(let* ((added (box #f)) (r (node-assoc (pmap-root m) 0 (key-hash k) k v added))
|
||||||
(cnt (pmap-cnt m)) (ord (pmap-order m)))
|
(cnt (pmap-cnt m)) (ord (pmap-order m)))
|
||||||
(if (unbox added)
|
(if (unbox added)
|
||||||
(if (and ord (fx<? cnt array-map-limit))
|
(if (and ord (pmap-array-keep? cnt ord k))
|
||||||
(make-pmap r (fx+ cnt 1) (append-key ord k))
|
(make-pmap r (fx+ cnt 1) (append-key ord k))
|
||||||
(make-pmap r (fx+ cnt 1) #f))
|
(make-pmap r (fx+ cnt 1) #f))
|
||||||
(make-pmap r cnt ord))))
|
(make-pmap r cnt ord))))
|
||||||
|
|
@ -352,10 +365,14 @@
|
||||||
(let loop ((ks ord) (a acc))
|
(let loop ((ks ord) (a acc))
|
||||||
(if (null? ks) a (loop (cdr ks) (proc (car ks) (pmap-get m (car ks) jolt-nil) a))))
|
(if (null? ks) a (loop (cdr ks) (proc (car ks) (pmap-get m (car ks) jolt-nil) a))))
|
||||||
(node-fold (pmap-root m) proc acc))))
|
(node-fold (pmap-root m) proc acc))))
|
||||||
;; map LITERAL ({...}): array map up to 8 entries, hash map beyond (RT.map).
|
;; map LITERAL ({...}): array map up to 8 entries (64 if keyword-only, per 1.13),
|
||||||
|
;; hash map beyond (RT.map).
|
||||||
(define (jolt-hash-map . kvs)
|
(define (jolt-hash-map . kvs)
|
||||||
(let loop ((m empty-pmap) (kvs kvs))
|
(let loop ((m empty-pmap) (kvs kvs))
|
||||||
(cond ((null? kvs) (if (fx>? (pmap-cnt m) array-map-limit) (pmap->hash m) m))
|
(cond ((null? kvs)
|
||||||
|
(let ((cnt (pmap-cnt m)) (ord (pmap-order m)))
|
||||||
|
(if (fx>? cnt (if (all-keywords? ord) array-map-limit-kw array-map-limit))
|
||||||
|
(pmap->hash m) m)))
|
||||||
((null? (cdr kvs)) (error 'hash-map "odd number of map literal entries"))
|
((null? (cdr kvs)) (error 'hash-map "odd number of map literal entries"))
|
||||||
(else (loop (pmap-put-ordered m (car kvs) (cadr kvs)) (cddr kvs))))))
|
(else (loop (pmap-put-ordered m (car kvs) (cadr kvs)) (cddr kvs))))))
|
||||||
;; array-map ctor: insertion-ordered regardless of size (createAsIfByAssoc).
|
;; array-map ctor: insertion-ordered regardless of size (createAsIfByAssoc).
|
||||||
|
|
|
||||||
|
|
@ -110,6 +110,38 @@
|
||||||
;; older seed during the first re-mint pass.
|
;; older seed during the first re-mint pass.
|
||||||
(let ((scv (var-deref "jolt.backend-scheme" "set-var-cache!")))
|
(let ((scv (var-deref "jolt.backend-scheme" "set-var-cache!")))
|
||||||
(when (procedure? scv) (scv #t)))
|
(when (procedure? scv) (scv #t)))
|
||||||
|
;; JOLT_TRACE is a falsey value (case-insensitive) — the single predicate both the
|
||||||
|
;; dev-mode enable and the whole-run enable consult, so "off" never accidentally
|
||||||
|
;; means "on". An empty / unset value is NOT falsey here — it carries no signal, so
|
||||||
|
;; dev mode still traces and a whole run still doesn't.
|
||||||
|
(define (jolt-trace-env-off? e)
|
||||||
|
(and (string? e)
|
||||||
|
(let ((s (string-downcase e)))
|
||||||
|
(or (string=? s "0") (string=? s "false") (string=? s "no")
|
||||||
|
(string=? s "off") (string=? s "n")))))
|
||||||
|
;; Tail-frame history. Turning it on makes the emitter add a per-fn history push to
|
||||||
|
;; every fn compiled AFTERWARD, and allocates this thread's ring. Suppressed when
|
||||||
|
;; JOLT_TRACE is a falsey value, so JOLT_TRACE=0 / off / no disables it in dev mode.
|
||||||
|
(define (jolt-enable-trace!)
|
||||||
|
(unless (jolt-trace-env-off? (getenv "JOLT_TRACE"))
|
||||||
|
(let ((stf (var-deref "jolt.backend-scheme" "set-trace-frames!")))
|
||||||
|
(when (procedure? stf) (stf #t)))
|
||||||
|
(jolt-trace-enable!)))
|
||||||
|
;; Exposed so the REPL / nREPL entrypoints (jolt.main, jolt.nrepl) can turn tracing
|
||||||
|
;; on for REPL-driven development without the user setting JOLT_TRACE. Because the
|
||||||
|
;; push is baked in at compile time, only code compiled after this call is traced —
|
||||||
|
;; which is exactly the code you eval / reload in a live session.
|
||||||
|
(def-var! "jolt.host" "enable-trace!" jolt-enable-trace!)
|
||||||
|
;; Explicit opt-in for a whole run (JOLT_TRACE=1): turn tracing on BEFORE any app
|
||||||
|
;; namespace is compiled, so a plain `-M:run` traces the app's own code too. Called
|
||||||
|
;; from the runtime entrypoints (cli.ss, and the built joltc launcher) — NOT at load
|
||||||
|
;; time: a built joltc runs top-level forms at heap-build time, where JOLT_TRACE is
|
||||||
|
;; always unset, so a load-time check would never see the user's runtime env. Only an
|
||||||
|
;; affirmative value (set, non-empty, not falsey) forces it on.
|
||||||
|
(define (jolt-trace-init-from-env!)
|
||||||
|
(let ((e (getenv "JOLT_TRACE")))
|
||||||
|
(when (and e (fx>? (string-length e) 0) (not (jolt-trace-env-off? e)))
|
||||||
|
(jolt-enable-trace!))))
|
||||||
|
|
||||||
;; (with-meta sym m) -> sym, else x — an (ns ^:no-doc name …) yields the name with
|
;; (with-meta sym m) -> sym, else x — an (ns ^:no-doc name …) yields the name with
|
||||||
;; reader metadata as a with-meta form; strip it to read the bare ns symbol.
|
;; reader metadata as a with-meta form; strip it to read the bare ns symbol.
|
||||||
|
|
@ -235,6 +267,9 @@
|
||||||
;; record this form's source location first, so a compile- or run-time error
|
;; record this form's source location first, so a compile- or run-time error
|
||||||
;; in it reports the right place.
|
;; in it reports the right place.
|
||||||
(jolt-enter-form! form)
|
(jolt-enter-form! form)
|
||||||
|
;; drop tail-frame history from earlier top-level forms, so an error's trace
|
||||||
|
;; shows only this form's own call history (a no-op unless JOLT_TRACE is on).
|
||||||
|
(jolt-trace-reset!)
|
||||||
(eval (read (open-input-string (jolt-analyze-emit-form form ns)))
|
(eval (read (open-input-string (jolt-analyze-emit-form form ns)))
|
||||||
(interaction-environment)))))
|
(interaction-environment)))))
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -46,6 +46,10 @@
|
||||||
;; after it). Guarded for the first re-mint pass off an older seed.
|
;; after it). Guarded for the first re-mint pass off an older seed.
|
||||||
(let ((scv (var-deref "jolt.backend-scheme" "set-var-cache!")))
|
(let ((scv (var-deref "jolt.backend-scheme" "set-var-cache!")))
|
||||||
(when (procedure? scv) (scv #f)))
|
(when (procedure? scv) (scv #f)))
|
||||||
|
;; Tail-frame tracing off for the mint + `jolt build`: the seed must stay a
|
||||||
|
;; byte-fixpoint, and a built app should carry no per-call trace overhead.
|
||||||
|
(let ((stf (var-deref "jolt.backend-scheme" "set-trace-frames!")))
|
||||||
|
(when (procedure? stf) (stf #f)))
|
||||||
(define (ei-compile-form ctx f optimize?)
|
(define (ei-compile-form ctx f optimize?)
|
||||||
(let ((ir (jolt-ce-analyze ctx f)))
|
(let ((ir (jolt-ce-analyze ctx f)))
|
||||||
(jolt-ce-emit-top (if optimize? (jolt-ce-run-passes ir ctx) ir))))
|
(jolt-ce-emit-top (if optimize? (jolt-ce-run-passes ir ctx) ir))))
|
||||||
|
|
|
||||||
|
|
@ -579,9 +579,9 @@
|
||||||
;; pthread_sigmask"). Guard so a non-POSIX host yields #f; jolt-set-sigint-blocked
|
;; pthread_sigmask"). Guard so a non-POSIX host yields #f; jolt-set-sigint-blocked
|
||||||
;; then no-ops (Windows delivers ^C through the console, not a per-thread mask).
|
;; then no-ops (Windows delivers ^C through the console, not a per-thread mask).
|
||||||
(define c-pthread-sigmask
|
(define c-pthread-sigmask
|
||||||
(guard (e (#t #f)) (foreign-procedure "pthread_sigmask" (int u8* u8*) int)))
|
(jolt-foreign-proc-safe "pthread_sigmask" '(int u8* u8*) 'int))
|
||||||
(define c-sigemptyset (guard (e (#t #f)) (foreign-procedure "sigemptyset" (u8*) int)))
|
(define c-sigemptyset (jolt-foreign-proc-safe "sigemptyset" '(u8*) 'int))
|
||||||
(define c-sigaddset (guard (e (#t #f)) (foreign-procedure "sigaddset" (u8* int) int)))
|
(define c-sigaddset (jolt-foreign-proc-safe "sigaddset" '(u8* int) 'int))
|
||||||
;; POSIX SIG_BLOCK/SIG_UNBLOCK numerics differ by platform: Linux/glibc 0/1,
|
;; POSIX SIG_BLOCK/SIG_UNBLOCK numerics differ by platform: Linux/glibc 0/1,
|
||||||
;; Darwin/macOS 1/2 (SIG_UNBLOCK is SIG_BLOCK+1 on both). Resolve SIG_BLOCK for
|
;; Darwin/macOS 1/2 (SIG_UNBLOCK is SIG_BLOCK+1 on both). Resolve SIG_BLOCK for
|
||||||
;; this host from the machine-type symbol — macOS builds contain "osx".
|
;; this host from the machine-type symbol — macOS builds contain "osx".
|
||||||
|
|
|
||||||
|
|
@ -55,9 +55,7 @@
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(unless tried?
|
(unless tried?
|
||||||
(set! tried? #t)
|
(set! tried? #t)
|
||||||
(set! fp (guard (e (#t #f))
|
(set! fp (jolt-foreign-proc-safe "sched_yield" '() 'int)))
|
||||||
(load-shared-object #f)
|
|
||||||
(foreign-procedure "sched_yield" () int))))
|
|
||||||
(if fp (fp) (sleep (make-time 'time-duration 0 0)))
|
(if fp (fp) (sleep (make-time 'time-duration 0 0)))
|
||||||
jolt-nil)))
|
jolt-nil)))
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -80,13 +80,18 @@
|
||||||
;; every Chez binary) — no external toolchain. Falls back to /bin/sh chmod if the
|
;; every Chez binary) — no external toolchain. Falls back to /bin/sh chmod if the
|
||||||
;; symbol can't be resolved.
|
;; symbol can't be resolved.
|
||||||
(define jolt-chmod-755
|
(define jolt-chmod-755
|
||||||
(let ((c (guard (e (#t #f))
|
(let ((c (jolt-foreign-proc-safe "chmod" '(string int) 'int)))
|
||||||
(load-shared-object #f)
|
|
||||||
(foreign-procedure "chmod" (string int) int))))
|
|
||||||
(lambda (path)
|
(lambda (path)
|
||||||
(if c
|
(cond
|
||||||
(c path #o755)
|
(c (c path #o755))
|
||||||
(system (string-append "chmod 755 '" path "'"))))))
|
;; Windows has no chmod and needs none (execute is by extension)
|
||||||
|
((let ((m (symbol->string (machine-type))))
|
||||||
|
(let loop ((i 0))
|
||||||
|
(cond ((> (+ i 2) (string-length m)) #f)
|
||||||
|
((string=? (substring m i (+ i 2)) "nt") #t)
|
||||||
|
(else (loop (+ i 1))))))
|
||||||
|
0)
|
||||||
|
(else (system (string-append "chmod 755 '" path "'")))))))
|
||||||
|
|
||||||
;; A user-facing relative path resolves against JOLT_PWD — the user's cwd before
|
;; A user-facing relative path resolves against JOLT_PWD — the user's cwd before
|
||||||
;; the launcher cd'd to the jolt repo root — matching the JVM, where io/file is
|
;; the launcher cd'd to the jolt repo root — matching the JVM, where io/file is
|
||||||
|
|
|
||||||
|
|
@ -42,6 +42,20 @@ if [ "$got_e" != "45" ]; then
|
||||||
exit 1
|
exit 1
|
||||||
fi
|
fi
|
||||||
|
|
||||||
|
# 2b. JOLT_TRACE must take effect in the BUILT binary. The env check runs at
|
||||||
|
# runtime (the launcher), NOT at heap-build where JOLT_TRACE is always unset — so
|
||||||
|
# an uncaught error shows a tail-frame trace recovering the TCO-elided chain, and
|
||||||
|
# exactly ONE trace block (the launcher must not double-print it).
|
||||||
|
got_tr="$(env -i HOME="$HOME" JOLT_TRACE=1 "$joltc" -e '(defn a [x] (+ x 1)) (defn b [x] (a x)) (b :x)' 2>&1)"
|
||||||
|
if ! printf '%s' "$got_tr" | grep -q ' trace:' || ! printf '%s' "$got_tr" | grep -q 'b'; then
|
||||||
|
echo " FAIL: JOLT_TRACE=1 in the built joltc produced no tail-frame trace"
|
||||||
|
echo "--- got ---"; echo "$got_tr"; exit 1
|
||||||
|
fi
|
||||||
|
if [ "$(printf '%s' "$got_tr" | grep -c ' trace:')" != "1" ]; then
|
||||||
|
echo " FAIL: built joltc double-printed the trace block"
|
||||||
|
echo "--- got ---"; echo "$got_tr"; exit 1
|
||||||
|
fi
|
||||||
|
|
||||||
# 3. Build an app through the distributed joltc with an EMPTY environment — no
|
# 3. Build an app through the distributed joltc with an EMPTY environment — no
|
||||||
# PATH at all, so no chez, no cc, no shell tools are reachable. This is the core
|
# PATH at all, so no chez, no cc, no shell tools are reachable. This is the core
|
||||||
# guarantee: joltc compiles apps entirely on its own.
|
# guarantee: joltc compiles apps entirely on its own.
|
||||||
|
|
|
||||||
|
|
@ -384,3 +384,14 @@
|
||||||
(def-var! "jolt.host" "load-namespace" (lambda (n) (load-namespace n) jolt-nil))
|
(def-var! "jolt.host" "load-namespace" (lambda (n) (load-namespace n) jolt-nil))
|
||||||
(def-var! "jolt.host" "file-exists?" (lambda (p) (if (file-exists? p) #t #f)))
|
(def-var! "jolt.host" "file-exists?" (lambda (p) (if (file-exists? p) #t #f)))
|
||||||
(def-var! "jolt.host" "getenv" (lambda (n) (let ((v (getenv n))) (if v v jolt-nil))))
|
(def-var! "jolt.host" "getenv" (lambda (n) (let ((v (getenv n))) (if v v jolt-nil))))
|
||||||
|
|
||||||
|
;; jolt version string. A self-contained binary build bakes the real tag into the
|
||||||
|
;; saved heap by emitting (set! jolt-baked-version "…") in flat.ss; a dev run off
|
||||||
|
;; the seed leaves it #f and falls back to $JOLT_VERSION (bin/joltc sets it from
|
||||||
|
;; `git describe`), then "dev".
|
||||||
|
(define jolt-baked-version #f)
|
||||||
|
(def-var! "jolt.host" "jolt-version"
|
||||||
|
(lambda ()
|
||||||
|
(or jolt-baked-version
|
||||||
|
(let ((v (getenv "JOLT_VERSION"))) (and v (> (string-length v) 0) v))
|
||||||
|
"dev")))
|
||||||
|
|
|
||||||
117
host/chez/rt.ss
117
host/chez/rt.ss
|
|
@ -11,6 +11,17 @@
|
||||||
;; Emitted programs do `(load "host/chez/rt.ss")`; this loads values.ss in turn.
|
;; Emitted programs do `(load "host/chez/rt.ss")`; this loads values.ss in turn.
|
||||||
|
|
||||||
(load "host/chez/values.ss")
|
(load "host/chez/values.ss")
|
||||||
|
;; Resolve a libc entry point at RUN time. A literal (foreign-procedure "name" …)
|
||||||
|
;; in COMPILED code becomes a fasl relocation resolved when the boot loads — on a
|
||||||
|
;; platform lacking the symbol (chmod/sigaddset on Windows) that kills the boot
|
||||||
|
;; before any guard can run. eval defers the lookup to evaluation time, where the
|
||||||
|
;; guard works; returns #f when the entry doesn't exist.
|
||||||
|
(define (jolt-foreign-proc-safe name args res)
|
||||||
|
(guard (e (#t #f))
|
||||||
|
(load-shared-object #f)
|
||||||
|
(and (foreign-entry? name)
|
||||||
|
(eval `(foreign-procedure ,name ,args ,res)))))
|
||||||
|
|
||||||
(load "host/chez/collections.ss")
|
(load "host/chez/collections.ss")
|
||||||
(load "host/chez/seq.ss")
|
(load "host/chez/seq.ss")
|
||||||
|
|
||||||
|
|
@ -49,6 +60,112 @@
|
||||||
;; stack trace (source-registry.ss). call/cc is paid only on a throw, never per
|
;; stack trace (source-registry.ss). call/cc is paid only on a throw, never per
|
||||||
;; call; the captured k is walked, never invoked.
|
;; call; the captured k is walked, never invoked.
|
||||||
(define jolt-throw-cont (make-thread-parameter #f))
|
(define jolt-throw-cont (make-thread-parameter #f))
|
||||||
|
|
||||||
|
;; --- tail-frame history: a ring of rings (opt-in) ----------------------------
|
||||||
|
;; TCO erases tail-called frames from the native continuation, so an uncaught
|
||||||
|
;; error's backtrace shows only the surviving non-tail spine — the immediate error
|
||||||
|
;; site is often a tail call and is missing. When tracing is enabled (JOLT_TRACE,
|
||||||
|
;; wired in compile-eval.ss), each compiled fn records its frame-name on entry, and
|
||||||
|
;; the reporter reads this history to recover TCO-elided frames.
|
||||||
|
;;
|
||||||
|
;; The store is MIT-Scheme's "history" shape — a ring of rings. The OUTER ring
|
||||||
|
;; holds one RIB per non-tail subproblem (the real call spine); each rib's INNER
|
||||||
|
;; ring holds the recent tail-calls made AT that subproblem. A non-tail entry
|
||||||
|
;; advances the outer ring (a fresh rib); a tail entry rotates the current rib's
|
||||||
|
;; inner ring. So a tight tail loop (mutual recursion, a non-recur self-tail-call)
|
||||||
|
;; churns ONE rib's small inner ring instead of flushing the outer spine — the
|
||||||
|
;; caller context that led into the loop survives. Both rings are fixed-size, so
|
||||||
|
;; the whole history is bounded: a constant space factor, NOT a change to the
|
||||||
|
;; asymptotic space TCO guarantees.
|
||||||
|
;;
|
||||||
|
;; Whether an entry is tail or non-tail is set by the CALLER: the emitter marks a
|
||||||
|
;; tail call with (jolt-trace-mark! #t) right before it; a non-tail entry is the
|
||||||
|
;; default. NOTE this is best-effort: a tail call routed through jolt-invoke to a
|
||||||
|
;; target that has no entry prologue (a core/native fn, an anonymous fn held in a
|
||||||
|
;; var) does not consume the mark, so a following non-tail frame can be mislabeled
|
||||||
|
;; as a tail rotation — a cosmetic mis-grouping in the trace, never a wrong result.
|
||||||
|
(define jolt-trace-outer-size 48) ; ribs (non-tail spine depth kept)
|
||||||
|
(define jolt-trace-inner-size 6) ; tail-calls kept per subproblem
|
||||||
|
;; A history: #(ribs-vector outer-head outer-count). A rib: #(name-vector head count).
|
||||||
|
(define (jolt-make-rib) (vector (make-vector jolt-trace-inner-size #f) 0 0))
|
||||||
|
(define (jolt-make-history)
|
||||||
|
(let ((ribs (make-vector jolt-trace-outer-size #f)))
|
||||||
|
(let loop ((i 0))
|
||||||
|
(when (fx<? i jolt-trace-outer-size)
|
||||||
|
(vector-set! ribs i (jolt-make-rib)) (loop (fx+ i 1))))
|
||||||
|
(vector ribs 0 0)))
|
||||||
|
;; A global switch (all threads) plus a per-thread ring, lazily created on first
|
||||||
|
;; use — so code run on a spawned thread (a future/agent) records into ITS OWN
|
||||||
|
;; history, not the enabling thread's (make-thread-parameter hands a new thread the
|
||||||
|
;; initial #f, so we can't rely on inheritance).
|
||||||
|
(define jolt-trace-on? #f)
|
||||||
|
(define jolt-trace-ring (make-thread-parameter #f))
|
||||||
|
(define jolt-trace-tail? (make-thread-parameter #f)) ; caller-set, consumed per entry
|
||||||
|
(define (jolt-trace-enable!) (set! jolt-trace-on? #t) (jolt-trace-ring (jolt-make-history)))
|
||||||
|
;; this thread's ring, created on demand while tracing is on
|
||||||
|
(define (jolt-trace-cur-ring)
|
||||||
|
(or (jolt-trace-ring)
|
||||||
|
(and jolt-trace-on? (let ((h (jolt-make-history))) (jolt-trace-ring h) h))))
|
||||||
|
;; Drop accumulated history at a top-level boundary (compile-eval.ss calls this per
|
||||||
|
;; top-level form) so an error's trace shows only the forms that led to it, not the
|
||||||
|
;; frames of earlier, already-returned REPL/eval forms.
|
||||||
|
(define (jolt-trace-reset!)
|
||||||
|
(when (jolt-trace-ring) (jolt-trace-ring (jolt-make-history)) (jolt-trace-tail? #f)))
|
||||||
|
(define (jolt-trace-mark! t) (jolt-trace-tail? t))
|
||||||
|
|
||||||
|
;; push name into a rib's inner ring
|
||||||
|
(define (jolt-rib-push! rib name)
|
||||||
|
(let ((buf (vector-ref rib 0)) (i (vector-ref rib 1)) (cnt (vector-ref rib 2)))
|
||||||
|
(vector-set! buf i name)
|
||||||
|
(vector-set! rib 1 (fxmod (fx+ i 1) jolt-trace-inner-size))
|
||||||
|
(when (fx<? cnt jolt-trace-inner-size) (vector-set! rib 2 (fx+ cnt 1)))))
|
||||||
|
;; a non-tail entry: advance the outer ring, reset the new rib, seed it with name
|
||||||
|
(define (jolt-history-nontail! h name)
|
||||||
|
(let* ((ribs (vector-ref h 0)) (oh (vector-ref h 1)) (oc (vector-ref h 2))
|
||||||
|
(rib (vector-ref ribs oh)))
|
||||||
|
(vector-set! rib 1 0) (vector-set! rib 2 0)
|
||||||
|
(jolt-rib-push! rib name)
|
||||||
|
(vector-set! h 1 (fxmod (fx+ oh 1) jolt-trace-outer-size))
|
||||||
|
(when (fx<? oc jolt-trace-outer-size) (vector-set! h 2 (fx+ oc 1)))))
|
||||||
|
;; a tail entry: rotate the CURRENT rib's inner ring (bootstrap a rib if none yet)
|
||||||
|
(define (jolt-history-tail! h name)
|
||||||
|
(if (fx=? (vector-ref h 2) 0)
|
||||||
|
(jolt-history-nontail! h name)
|
||||||
|
(let* ((ribs (vector-ref h 0))
|
||||||
|
(cur (fxmod (fx+ (fx- (vector-ref h 1) 1) jolt-trace-outer-size)
|
||||||
|
jolt-trace-outer-size)))
|
||||||
|
(jolt-rib-push! (vector-ref ribs cur) name))))
|
||||||
|
;; Record a frame entry, routed by the caller's tail mark; then reset the mark so a
|
||||||
|
;; subsequent entry reached WITHOUT a mark (e.g. via apply) defaults to non-tail.
|
||||||
|
(define (jolt-trace-push! name)
|
||||||
|
(let ((h (jolt-trace-cur-ring)))
|
||||||
|
(when h
|
||||||
|
(if (jolt-trace-tail?) (jolt-history-tail! h name) (jolt-history-nontail! h name))
|
||||||
|
(jolt-trace-tail? #f)))
|
||||||
|
jolt-nil)
|
||||||
|
|
||||||
|
;; a rib's inner names, most-recent (deepest) tail first
|
||||||
|
(define (jolt-rib-names rib)
|
||||||
|
(let ((buf (vector-ref rib 0)) (head (vector-ref rib 1)) (cnt (vector-ref rib 2)))
|
||||||
|
(let loop ((k 1) (acc '()))
|
||||||
|
(if (fx>? k cnt)
|
||||||
|
(reverse acc)
|
||||||
|
(loop (fx+ k 1)
|
||||||
|
(cons (vector-ref buf (fxmod (fx+ (fx- head k) jolt-trace-inner-size)
|
||||||
|
jolt-trace-inner-size))
|
||||||
|
acc))))))
|
||||||
|
;; The whole history flattened to frame-names, most-recent (deepest) first:
|
||||||
|
;; current rib's tail-history, then its non-tail caller's, and so on outward.
|
||||||
|
(define (jolt-trace-snapshot)
|
||||||
|
(let ((h (jolt-trace-ring)))
|
||||||
|
(if (not h) '()
|
||||||
|
(let* ((ribs (vector-ref h 0)) (oh (vector-ref h 1)) (oc (vector-ref h 2)))
|
||||||
|
(let loop ((k 1) (acc '()))
|
||||||
|
(if (fx>? k oc)
|
||||||
|
(apply append (reverse acc))
|
||||||
|
(let ((idx (fxmod (fx+ (fx- oh k) jolt-trace-outer-size) jolt-trace-outer-size)))
|
||||||
|
(loop (fx+ k 1) (cons (jolt-rib-names (vector-ref ribs idx)) acc)))))))))
|
||||||
|
|
||||||
(define-condition-type &jolt-throw &condition
|
(define-condition-type &jolt-throw &condition
|
||||||
make-jolt-throw-condition jolt-throw-condition?
|
make-jolt-throw-condition jolt-throw-condition?
|
||||||
(value jolt-throw-condition-value))
|
(value jolt-throw-condition-value))
|
||||||
|
|
|
||||||
|
|
@ -11,7 +11,7 @@
|
||||||
;; reset between cases so there is no leakage — same isolation a fresh process gives.
|
;; reset between cases so there is no leakage — same isolation a fresh process gives.
|
||||||
;;
|
;;
|
||||||
;; chez --script host/chez/run-corpus.ss
|
;; chez --script host/chez/run-corpus.ss
|
||||||
;; JOLT_CHEZ_ZJ_FLOOR=N override the regression floor (default 2730)
|
;; JOLT_CHEZ_ZJ_FLOOR=N override the regression floor (default 3390)
|
||||||
;; JOLT_CORPUS_LIMIT=N every-Nth stride (fast iteration; floor drops to 0)
|
;; JOLT_CORPUS_LIMIT=N every-Nth stride (fast iteration; floor drops to 0)
|
||||||
;; JOLT_DUMP_CRASH_LABELS=1 list crash + allowlisted labels
|
;; JOLT_DUMP_CRASH_LABELS=1 list crash + allowlisted labels
|
||||||
(import (chezscheme))
|
(import (chezscheme))
|
||||||
|
|
@ -196,7 +196,7 @@
|
||||||
|
|
||||||
;; Regression floor: fail on any NEW divergence or if pass drops below the floor.
|
;; Regression floor: fail on any NEW divergence or if pass drops below the floor.
|
||||||
(define base-floor (let ((s (getenv "JOLT_CHEZ_ZJ_FLOOR")))
|
(define base-floor (let ((s (getenv "JOLT_CHEZ_ZJ_FLOOR")))
|
||||||
(if s (string->number s) 2730)))
|
(if s (string->number s) 3390)))
|
||||||
(define floor (if limit 0 base-floor))
|
(define floor (if limit 0 base-floor))
|
||||||
(when (or (> (length diverged) 0) (< pass floor))
|
(when (or (> (length diverged) 0) (< pass floor))
|
||||||
(printf "REGRESSION: pass ~a < floor ~a or ~a new divergence(s)\n"
|
(printf "REGRESSION: pass ~a < floor ~a or ~a new divergence(s)\n"
|
||||||
|
|
|
||||||
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
|
|
@ -30,6 +30,39 @@ check_loc() {
|
||||||
fi
|
fi
|
||||||
}
|
}
|
||||||
|
|
||||||
|
# An uncaught error's stack trace must name the runtime-eval'd fn frames that
|
||||||
|
# survive TCO (the non-tail spine), even though the eval path registers no source
|
||||||
|
# map — "print what is available". Asserts a substring appears under " trace:".
|
||||||
|
check_trace() {
|
||||||
|
err="$(bin/joltc -e "$1" 2>&1 >/dev/null)"
|
||||||
|
if printf '%s' "$err" | grep -q ' trace:' && printf '%s' "$err" | grep -q "$2"; then
|
||||||
|
pass=$((pass + 1))
|
||||||
|
else
|
||||||
|
echo " FAIL (trace): $1"
|
||||||
|
echo " want stderr trace to contain \`$2\`, got \`$err\`"
|
||||||
|
fails=$((fails + 1))
|
||||||
|
fi
|
||||||
|
}
|
||||||
|
|
||||||
|
# JOLT_TRACE opts into the tail-frame history (the ring of rings): every $2 (an
|
||||||
|
# ERE) must match the " trace:" block. Used to assert TCO-elided frames are
|
||||||
|
# recovered and non-tail caller context survives a tail loop.
|
||||||
|
check_trace_on() {
|
||||||
|
err="$(JOLT_TRACE=1 bin/joltc -e "$1" 2>&1 >/dev/null)"
|
||||||
|
ok=1
|
||||||
|
printf '%s' "$err" | grep -q ' trace:' || ok=0
|
||||||
|
shift
|
||||||
|
for want in "$@"; do
|
||||||
|
printf '%s' "$err" | grep -Eq "$want" || ok=0
|
||||||
|
done
|
||||||
|
if [ "$ok" = 1 ]; then
|
||||||
|
pass=$((pass + 1))
|
||||||
|
else
|
||||||
|
echo " FAIL (trace-on): want [$*] in trace, got \`$err\`"
|
||||||
|
fails=$((fails + 1))
|
||||||
|
fi
|
||||||
|
}
|
||||||
|
|
||||||
check '(+ 1 2)' '3'
|
check '(+ 1 2)' '3'
|
||||||
check '(defn fib [n] (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) (fib 15)' '610'
|
check '(defn fib [n] (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) (fib 15)' '610'
|
||||||
check '(->> (range 10) (filter even?) (map (fn [x] (* x x))) (reduce +))' '120'
|
check '(->> (range 10) (filter even?) (map (fn [x] (* x x))) (reduce +))' '120'
|
||||||
|
|
@ -60,6 +93,53 @@ check '(try (load-string "(+") (catch :default e (ex-message e)))' 'EOF while re
|
||||||
check_loc '(throw (ex-info "boom" {}))' 'boom'
|
check_loc '(throw (ex-info "boom" {}))' 'boom'
|
||||||
check_loc '(do (+ 1 1) (/ 1 0))' ' at 1:'
|
check_loc '(do (+ 1 1) (/ 1 0))' ' at 1:'
|
||||||
|
|
||||||
|
# Runtime-eval'd fns aren't source-mapped, but their native frame names survive on
|
||||||
|
# the non-tail spine; the trace must show them. deepest/+ are tail calls (erased);
|
||||||
|
# middle and outer wait on a non-tail (inc …) so their frames are live at the throw.
|
||||||
|
trace_prog='(defn deepest [x] (+ x 1)) (defn middle [x] (inc (deepest x))) (defn outer [x] (inc (middle x))) (outer :nan)'
|
||||||
|
check_trace "$trace_prog" 'middle'
|
||||||
|
check_trace "$trace_prog" 'outer'
|
||||||
|
|
||||||
|
# JOLT_TRACE (tail-frame history / ring of rings). An all-tail chain is entirely
|
||||||
|
# TCO-erased from the continuation, but the history recovers every frame — incl.
|
||||||
|
# `deepest`, the actual error site.
|
||||||
|
check_trace_on '(defn deepest [x] (+ x 1)) (defn middle [x] (deepest x)) (defn outer [x] (middle x)) (outer :nan)' \
|
||||||
|
'deepest' 'middle' 'outer'
|
||||||
|
# A tail loop (a<->b) under a NON-tail caller: the loop is confined to one rib's
|
||||||
|
# bounded inner ring, so the caller context (`driver`, `top`) is NOT flushed out —
|
||||||
|
# the point of the ring of rings.
|
||||||
|
check_trace_on '(declare b) (defn a [n] (if (zero? n) (+ :x 1) (b (dec n)))) (defn b [n] (a n)) (defn driver [] (inc (a 6))) (defn top [] (inc (driver))) (top)' \
|
||||||
|
'driver' 'top'
|
||||||
|
# A ^long/^double return hint wraps the body in a coercion, so the hinted fn's call
|
||||||
|
# is NOT a tail call — its own frame is still live and must appear (not be elided).
|
||||||
|
check_trace_on '(defn g [n] (+ :x n)) (defn ^long f [n] (g n)) (f 3)' 'f' 'g'
|
||||||
|
# History is per top-level form: a later form's error trace shows its own frames
|
||||||
|
# (h2/u2), not frames from an earlier, already-returned form (h1/u1).
|
||||||
|
check_trace_on '(defn h1 [x] (inc x)) (defn u1 [] (inc (h1 5))) (u1) (defn h2 [x] (+ :x x)) (defn u2 [] (inc (h2 5))) (u2)' \
|
||||||
|
'h2' 'u2'
|
||||||
|
err_stale="$(JOLT_TRACE=1 bin/joltc -e '(defn h1 [x] (inc x)) (defn u1 [] (inc (h1 5))) (u1) (defn h2 [x] (+ :x x)) (defn u2 [] (inc (h2 5))) (u2)' 2>&1 >/dev/null)"
|
||||||
|
if printf '%s' "$err_stale" | grep -q 'h1'; then
|
||||||
|
echo " FAIL (trace-on): stale frame h1 from an earlier form leaked into the trace"
|
||||||
|
fails=$((fails + 1))
|
||||||
|
else
|
||||||
|
pass=$((pass + 1))
|
||||||
|
fi
|
||||||
|
# A file-backed project run maps each runtime-compiled frame to ns/name (file:line)
|
||||||
|
# — the eval path registers source in trace mode, so the trace isn't bare names.
|
||||||
|
tr_proj="$(mktemp -d)"
|
||||||
|
mkdir -p "$tr_proj/src/tp"
|
||||||
|
printf '{:paths ["src"] :aliases {:run {:main-opts ["-m" "tp.core"]}}}\n' > "$tr_proj/deps.edn"
|
||||||
|
printf '(ns tp.core)\n(defn deep [x] (+ x 1))\n(defn mid [x] (inc (deep x)))\n(defn -main [& _] (mid :nan))\n' > "$tr_proj/src/tp/core.clj"
|
||||||
|
tr_out="$(JOLT_TRACE=1 JOLT_PWD="$tr_proj" bin/joltc -M:run 2>&1)"
|
||||||
|
if printf '%s' "$tr_out" | grep -Eq 'tp\.core/deep \(.*/tp/core\.clj:2\)'; then
|
||||||
|
pass=$((pass + 1))
|
||||||
|
else
|
||||||
|
echo " FAIL: JOLT_TRACE trace should map a frame to ns/name (file:line)"
|
||||||
|
printf '%s\n' "$tr_out" | sed 's/^/ | /'
|
||||||
|
fails=$((fails + 1))
|
||||||
|
fi
|
||||||
|
rm -rf "$tr_proj"
|
||||||
|
|
||||||
# --help prints usage, and lists the nREPL server under its real flag name.
|
# --help prints usage, and lists the nREPL server under its real flag name.
|
||||||
help_out="$(bin/joltc --help 2>/dev/null)"
|
help_out="$(bin/joltc --help 2>/dev/null)"
|
||||||
if printf '%s' "$help_out" | grep -q -- '--nrepl-server'; then
|
if printf '%s' "$help_out" | grep -q -- '--nrepl-server'; then
|
||||||
|
|
@ -159,5 +239,25 @@ else
|
||||||
fails=$((fails + 1))
|
fails=$((fails + 1))
|
||||||
fi
|
fi
|
||||||
|
|
||||||
|
# REPL-driven development traces by default: an error in an evaluated form shows a
|
||||||
|
# tail-frame backtrace with no JOLT_TRACE set. rb tail-calls ra tail-calls +, all
|
||||||
|
# TCO-elided from the continuation — only the history recovers them.
|
||||||
|
repl_err="$(printf '(defn ra [x] (+ x 1))\n(defn rb [x] (ra x))\n(rb :nan)\n:exit\n' | bin/joltc repl 2>&1)"
|
||||||
|
if printf '%s' "$repl_err" | grep -q ' trace:' && printf '%s' "$repl_err" | grep -q 'rb'; then
|
||||||
|
pass=$((pass + 1))
|
||||||
|
else
|
||||||
|
echo " FAIL: a REPL error should show a tail-frame trace by default"
|
||||||
|
printf '%s\n' "$repl_err" | sed 's/^/ | /'
|
||||||
|
fails=$((fails + 1))
|
||||||
|
fi
|
||||||
|
# JOLT_TRACE=0 opts out — no trace in the REPL.
|
||||||
|
repl_off="$(printf '(defn ra [x] (+ x 1))\n(defn rb [x] (ra x))\n(rb :nan)\n:exit\n' | JOLT_TRACE=0 bin/joltc repl 2>&1)"
|
||||||
|
if printf '%s' "$repl_off" | grep -q ' trace:'; then
|
||||||
|
echo " FAIL: JOLT_TRACE=0 should suppress the REPL trace"
|
||||||
|
fails=$((fails + 1))
|
||||||
|
else
|
||||||
|
pass=$((pass + 1))
|
||||||
|
fi
|
||||||
|
|
||||||
echo "cli smoke: $pass passed, $fails failed"
|
echo "cli smoke: $pass passed, $fails failed"
|
||||||
[ "$fails" -eq 0 ]
|
[ "$fails" -eq 0 ]
|
||||||
|
|
|
||||||
|
|
@ -57,10 +57,36 @@
|
||||||
((symbol? nm) (symbol->string nm))
|
((symbol? nm) (symbol->string nm))
|
||||||
(else #f)))))))
|
(else #f)))))))
|
||||||
|
|
||||||
;; Walk a continuation, returning the registered jolt frames (innermost first) as
|
;; Frame names that are pure Chez / jolt-runtime plumbing — the eval boundary,
|
||||||
;; (frame-name . record) pairs, where record is #(ns name file line) or the symbol
|
;; the var-cell trampoline, continuation/winder internals. They carry no Clojure
|
||||||
;; 'ambiguous. Unmapped frames (host spine, anonymous lambdas) are skipped; raw
|
;; meaning, so an unmapped frame with one of these names is dropped from the trace
|
||||||
;; depth is capped.
|
;; (a MAPPED frame is always kept — a jolt fn that happens to share the name still
|
||||||
|
;; resolves to its source). Any name Chez prefixes with `$` (system) or that jolt
|
||||||
|
;; prefixes with `jolt-` (host runtime) is plumbing too.
|
||||||
|
(define srcreg-plumbing-names
|
||||||
|
(let ((h (make-hashtable string-hash string=?)))
|
||||||
|
(for-each (lambda (s) (hashtable-set! h s #t))
|
||||||
|
'("dynamic-wind" "winder-dummy" "ksrc" "invoke" "apply"
|
||||||
|
"call-with-values" "call/cc" "call-with-current-continuation"
|
||||||
|
"raise" "raise-continuable" "with-exception-handler" "guard"
|
||||||
|
"eval" "compile" "interpret" "expand" "read" "load"
|
||||||
|
;; host dispatch/coercion helpers (not `jolt-` prefixed) that carry
|
||||||
|
;; no Clojure meaning in a trace
|
||||||
|
"record-method-dispatch" "protocol-resolve" "devirt-resolve"
|
||||||
|
"list->cseq" "host-static-call" "host-call"))
|
||||||
|
h))
|
||||||
|
(define (srcreg-plumbing-name? nm)
|
||||||
|
(or (hashtable-ref srcreg-plumbing-names nm #f)
|
||||||
|
(and (fx>? (string-length nm) 0) (char=? (string-ref nm 0) #\$))
|
||||||
|
(and (fx>=? (string-length nm) 5) (string=? (substring nm 0 5) "jolt-"))))
|
||||||
|
|
||||||
|
;; Walk a continuation, returning its frames (innermost first) as (frame-name .
|
||||||
|
;; record) pairs. record is a source vector #(ns name file line) for a frame that
|
||||||
|
;; maps to registered Clojure source, the symbol 'ambiguous for a short name shared
|
||||||
|
;; across namespaces, or #f for an unmapped-but-named frame (the common case on the
|
||||||
|
;; open-world eval path, where nothing is registered — the bare frame name is still
|
||||||
|
;; a useful trace line). Plumbing frames (host spine, eval boundary) and unnamed
|
||||||
|
;; frames are skipped; raw depth is capped.
|
||||||
(define (jolt-frame-records k)
|
(define (jolt-frame-records k)
|
||||||
;; read the env at call time, not load time: a built binary runs top-level forms
|
;; read the env at call time, not load time: a built binary runs top-level forms
|
||||||
;; at heap-build time, where this would always be unset.
|
;; at heap-build time, where this would always be unset.
|
||||||
|
|
@ -70,26 +96,32 @@
|
||||||
(if (or (not io) (fx>=? n 400))
|
(if (or (not io) (fx>=? n 400))
|
||||||
(reverse acc)
|
(reverse acc)
|
||||||
(let* ((nm (srcreg-frame-name io))
|
(let* ((nm (srcreg-frame-name io))
|
||||||
(src (and nm (hashtable-ref source-registry nm #f))))
|
(src (and nm (hashtable-ref source-registry nm #f)))
|
||||||
|
;; keep a frame that maps, or any named frame that isn't plumbing
|
||||||
|
(keep? (and nm (or src (not (srcreg-plumbing-name? nm))))))
|
||||||
(when (and debug? nm)
|
(when (and debug? nm)
|
||||||
(display (string-append " [frame] " nm (if src " *MAPPED*" "") "\n")
|
(display (string-append " [frame] " nm (if src " *MAPPED*"
|
||||||
|
(if keep? "" " (skipped)")) "\n")
|
||||||
(current-error-port)))
|
(current-error-port)))
|
||||||
(loop (guard (e (#t #f)) (io 'link)) (fx+ n 1)
|
(loop (guard (e (#t #f)) (io 'link)) (fx+ n 1)
|
||||||
(if src (cons (cons nm src) acc) acc))))))))
|
(if keep? (cons (cons nm src) acc) acc))))))))
|
||||||
|
|
||||||
;; Multi-line backtrace for an uncaught value — " ns/name (file:line)" for a
|
;; Render a list of (frame-name . record) pairs (innermost/deepest first) to a
|
||||||
;; mapped frame, the bare frame name for an ambiguous one — or #f when no jolt
|
;; backtrace string. record is a source vector #(ns name file line) -> "ns/name
|
||||||
;; frame maps (the caller then prints just the top-level location). Capped to the
|
;; (file:line)", or 'ambiguous / #f -> the bare frame name. A run of the same
|
||||||
;; innermost frames.
|
;; frame-name collapses to one "name (xN)" line (deep recursion, or a hot fn a
|
||||||
(define (jolt-backtrace-string v)
|
;; loop re-enters), and the number of distinct lines is capped.
|
||||||
(let ((k (jolt-error-continuation v)))
|
(define (jolt-render-recs recs)
|
||||||
(and k
|
|
||||||
(let ((recs (jolt-frame-records k)))
|
|
||||||
(and (pair? recs)
|
|
||||||
(let ((port (open-output-string)))
|
(let ((port (open-output-string)))
|
||||||
(let loop ((rs recs) (shown 0))
|
(let loop ((rs recs) (shown 0))
|
||||||
(when (and (pair? rs) (fx<? shown 30))
|
(if (or (null? rs) (fx>=? shown 30))
|
||||||
|
(get-output-string port)
|
||||||
(let* ((p (car rs)) (frame-name (car p)) (r (cdr p)))
|
(let* ((p (car rs)) (frame-name (car p)) (r (cdr p)))
|
||||||
|
;; count a maximal run of the same frame-name
|
||||||
|
(let run ((tail (cdr rs)) (cnt 1))
|
||||||
|
(if (and (pair? tail) (string=? (car (car tail)) frame-name))
|
||||||
|
(run (cdr tail) (fx+ cnt 1))
|
||||||
|
(begin
|
||||||
(put-string port " ")
|
(put-string port " ")
|
||||||
(if (vector? r)
|
(if (vector? r)
|
||||||
(let ((ns (vector-ref r 0)) (nm (vector-ref r 1))
|
(let ((ns (vector-ref r 0)) (nm (vector-ref r 1))
|
||||||
|
|
@ -99,10 +131,49 @@
|
||||||
(put-string port " (") (put-string port file)
|
(put-string port " (") (put-string port file)
|
||||||
(put-string port ":") (put-string port (number->string line))
|
(put-string port ":") (put-string port (number->string line))
|
||||||
(put-string port ")")))
|
(put-string port ")")))
|
||||||
(put-string port frame-name)) ; 'ambiguous: bare name
|
(put-string port frame-name)) ; 'ambiguous / unmapped: bare name
|
||||||
(put-char port #\newline))
|
(when (fx>? cnt 1)
|
||||||
(loop (cdr rs) (fx+ shown 1))))
|
(put-string port " (x") (put-string port (number->string cnt)) (put-string port ")"))
|
||||||
(get-output-string port)))))))
|
(put-char port #\newline)
|
||||||
|
(loop tail (fx+ shown 1))))))))))
|
||||||
|
|
||||||
|
;; Multi-line backtrace for an uncaught value. Two sources, in preference order:
|
||||||
|
;; 1. The tail-frame history ring (rt.ss), when JOLT_TRACE enabled it — an
|
||||||
|
;; execution history of the runtime-compiled fns entered before the throw,
|
||||||
|
;; INCLUDING ones TCO erased from the live continuation. Most-recent first.
|
||||||
|
;; 2. Otherwise the live continuation (jolt-frame-records) — the accurate but
|
||||||
|
;; TCO-truncated non-tail spine.
|
||||||
|
;; Each frame maps to "ns/name (file:line)" when registered, else its bare name.
|
||||||
|
;; #f when neither source yields a frame (the caller then prints just the location).
|
||||||
|
;; The tail-frame history ring rendered as a backtrace, or #f when tracing is off /
|
||||||
|
;; empty. A mapped frame is kept; else drop plumbing (same rule as the continuation
|
||||||
|
;; path) so the two sources read consistently.
|
||||||
|
(define (jolt-history-backtrace)
|
||||||
|
(let* ((hist (jolt-trace-snapshot))
|
||||||
|
(recs (let loop ((ns hist) (acc '()))
|
||||||
|
(if (null? ns)
|
||||||
|
(reverse acc)
|
||||||
|
(let* ((nm (car ns)) (src (hashtable-ref source-registry nm #f)))
|
||||||
|
(loop (cdr ns)
|
||||||
|
(if (or src (not (srcreg-plumbing-name? nm)))
|
||||||
|
(cons (cons nm src) acc) acc)))))))
|
||||||
|
(and (pair? recs) (jolt-render-recs recs))))
|
||||||
|
|
||||||
|
(define (jolt-backtrace-string v)
|
||||||
|
(or (jolt-history-backtrace)
|
||||||
|
(let ((k (jolt-error-continuation v)))
|
||||||
|
(and k
|
||||||
|
(let ((recs (jolt-frame-records k)))
|
||||||
|
(and (pair? recs) (jolt-render-recs recs)))))))
|
||||||
|
|
||||||
|
;; Exposed for the REPL / nREPL error paths, which catch errors themselves instead
|
||||||
|
;; of going through the uncaught reporter. Returns the " trace:\n<frames>" block
|
||||||
|
;; from the tail-frame HISTORY only — the live continuation in a REPL is just the
|
||||||
|
;; REPL's own machinery — or nil when tracing is off (so a caller can when-let).
|
||||||
|
(def-var! "jolt.host" "backtrace-string"
|
||||||
|
(lambda ()
|
||||||
|
(let ((bt (jolt-history-backtrace)))
|
||||||
|
(if bt (string-append " trace:\n" bt) jolt-nil))))
|
||||||
|
|
||||||
;; Render an uncaught jolt throw (any value, not just a Chez condition) to a port:
|
;; Render an uncaught jolt throw (any value, not just a Chez condition) to a port:
|
||||||
;; an ex-info shows its message + ex-data (+ a host cause); anything else is
|
;; an ex-info shows its message + ex-data (+ a host cause); anything else is
|
||||||
|
|
|
||||||
|
|
@ -26,6 +26,12 @@ static int self_path(char *buf, uint32_t size) {
|
||||||
/* _NSGetExecutablePath fills buf and reports the needed size on overflow. */
|
/* _NSGetExecutablePath fills buf and reports the needed size on overflow. */
|
||||||
return _NSGetExecutablePath(buf, &size);
|
return _NSGetExecutablePath(buf, &size);
|
||||||
}
|
}
|
||||||
|
#elif defined(_WIN32)
|
||||||
|
#include <windows.h>
|
||||||
|
static int self_path(char *buf, uint32_t size) {
|
||||||
|
DWORD n = GetModuleFileNameA(NULL, buf, size);
|
||||||
|
return (n == 0 || n >= size) ? -1 : 0;
|
||||||
|
}
|
||||||
#else
|
#else
|
||||||
#include <unistd.h>
|
#include <unistd.h>
|
||||||
static int self_path(char *buf, uint32_t size) {
|
static int self_path(char *buf, uint32_t size) {
|
||||||
|
|
|
||||||
|
|
@ -86,7 +86,11 @@
|
||||||
(if (fx<? i cnt) (begin (vector-set! out i (vector-ref buf i)) (loop (fx+ i 1)))
|
(if (fx<? i cnt) (begin (vector-set! out i (vector-ref buf i)) (loop (fx+ i 1)))
|
||||||
(make-pvec out)))))))
|
(make-pvec out)))))))
|
||||||
((map)
|
((map)
|
||||||
(let* ((ht (jolt-transient-buf t)) (cnt (hashtable-size ht)) (cap (jolt-transient-n t)))
|
(let* ((ht (jolt-transient-buf t)) (cnt (hashtable-size ht)) (cap (jolt-transient-n t))
|
||||||
|
;; Clojure 1.13: a keyword-only map stays an array map up to 64 entries,
|
||||||
|
;; so a keyword map built through a transient (into {} …) keeps insertion
|
||||||
|
;; order to 64, matching the literal/assoc paths.
|
||||||
|
(cap (if (all-keywords? (jolt-transient-ord t)) (fxmax array-map-limit-kw cap) cap)))
|
||||||
(if (fx>? cnt cap)
|
(if (fx>? cnt cap)
|
||||||
;; promoted past the array capacity: hash order
|
;; promoted past the array capacity: hash order
|
||||||
(let ((m empty-pmap-hash))
|
(let ((m empty-pmap-hash))
|
||||||
|
|
|
||||||
|
|
@ -188,9 +188,23 @@
|
||||||
[false nil]
|
[false nil]
|
||||||
(if or-map (keys or-map) [])))
|
(if or-map (keys or-map) [])))
|
||||||
amp? (fn* [x] (and (symbol? x) (= "&" (name x))))
|
amp? (fn* [x] (and (symbol? x) (= "&" (name x))))
|
||||||
|
;; split a :keys/:syms/:strs name list at & into [sym bind?] pairs. Names
|
||||||
|
;; before & bind normally (bind? true); names after & are declared-only
|
||||||
|
;; (bind? false) — accepted keys (:keys) or required keys (:keys!), per
|
||||||
|
;; CLJ-2961.
|
||||||
|
classify
|
||||||
|
(fn* [names]
|
||||||
|
(nth (reduce (fn* [st x]
|
||||||
|
(if (amp? x)
|
||||||
|
[(nth st 0) false]
|
||||||
|
[(conj (nth st 0) [x (nth st 1)]) (nth st 1)]))
|
||||||
|
[[] true] names)
|
||||||
|
0))
|
||||||
proc
|
proc
|
||||||
(fn* proc [pat init acc]
|
(fn* proc [pat init acc]
|
||||||
(cond
|
(cond
|
||||||
|
;; CLJ-2954: & is reserved for destructuring rest, never a binding.
|
||||||
|
(amp? pat) (throw (new IllegalArgumentException "Can't use & as a local binding"))
|
||||||
(symbol? pat) (conj (conj acc pat) init)
|
(symbol? pat) (conj (conj acc pat) init)
|
||||||
(vector? pat)
|
(vector? pat)
|
||||||
(let* [g (symbol (str (gensym)))
|
(let* [g (symbol (str (gensym)))
|
||||||
|
|
@ -231,30 +245,45 @@
|
||||||
;; group binds a :keys/:strs/:syms list. dnsp is the destructuring
|
;; group binds a :keys/:strs/:syms list. dnsp is the destructuring
|
||||||
;; namespace from a qualified key like :ns/keys — it both prefixes
|
;; namespace from a qualified key like :ns/keys — it both prefixes
|
||||||
;; the lookup key and overrides a bare symbol's namespace.
|
;; the lookup key and overrides a bare symbol's namespace.
|
||||||
|
;; group binds a :keys/:strs/:syms list. checked? marks the
|
||||||
|
;; :keys!/:strs!/:syms! variants (CLJ-2961): lookups use req!
|
||||||
|
;; (throw on missing) instead of get. A pair is [sym bind?];
|
||||||
|
;; bind? false (names after &) is declared-only — for checked
|
||||||
|
;; groups it still runs req! (bound to a throwaway gensym) to
|
||||||
|
;; enforce the key, for unchecked groups it's a no-op.
|
||||||
group
|
group
|
||||||
(fn* group [a names kind dnsp]
|
(fn* group [a names kind dnsp checked?]
|
||||||
(if names
|
(if names
|
||||||
(reduce
|
(reduce
|
||||||
;; s is a symbol (a b) or a keyword (:a :b); name/
|
;; s is a symbol (a b) or a keyword (:a :b); name/
|
||||||
;; namespace handle both, so :keys [:major] binds
|
;; namespace handle both, so :keys [:major] binds
|
||||||
;; `major` looking up :major (str would keep the colon).
|
;; `major` looking up :major (str would keep the colon).
|
||||||
(fn* [aa s]
|
(fn* [aa pair]
|
||||||
(let* [local (name s)
|
(let* [s (nth pair 0)
|
||||||
|
bind? (nth pair 1)
|
||||||
|
local (name s)
|
||||||
nsp (or (namespace s) dnsp)
|
nsp (or (namespace s) dnsp)
|
||||||
keyform (cond
|
keyform (cond
|
||||||
(= kind :kw) (keyword (if nsp (str nsp "/" local) local))
|
(= kind :kw) (keyword (if nsp (str nsp "/" local) local))
|
||||||
(= kind :str) local
|
(= kind :str) local
|
||||||
:else `(quote ~(symbol nsp local)))
|
:else `(quote ~(symbol nsp local)))
|
||||||
fo (find-or or-map local)]
|
fo (find-or or-map local)
|
||||||
(conj (conj aa (symbol local))
|
lookup (cond
|
||||||
(if (nth fo 0)
|
checked? `(req! ~gm ~keyform)
|
||||||
`(get ~gm ~keyform ~(nth fo 1))
|
(nth fo 0) `(get ~gm ~keyform ~(nth fo 1))
|
||||||
`(get ~gm ~keyform)))))
|
:else `(get ~gm ~keyform))]
|
||||||
a names)
|
(cond
|
||||||
|
bind? (conj (conj aa (symbol local)) lookup)
|
||||||
|
checked? (conj (conj aa (symbol (str (gensym)))) lookup)
|
||||||
|
:else aa)))
|
||||||
|
a (classify names))
|
||||||
a))
|
a))
|
||||||
g1 (group base (get pat :keys) :kw nil)
|
g1 (group base (get pat :keys) :kw nil false)
|
||||||
g2 (group g1 (get pat :strs) :str nil)
|
g2 (group g1 (get pat :strs) :str nil false)
|
||||||
g3 (group g2 (get pat :syms) :sym nil)]
|
g3 (group g2 (get pat :syms) :sym nil false)
|
||||||
|
g4 (group g3 (get pat :keys!) :kw nil true)
|
||||||
|
g5 (group g4 (get pat :strs!) :str nil true)
|
||||||
|
g6 (group g5 (get pat :syms!) :sym nil true)]
|
||||||
;; remaining keys: a qualified :ns/keys|:ns/strs|:ns/syms groups under
|
;; remaining keys: a qualified :ns/keys|:ns/strs|:ns/syms groups under
|
||||||
;; its namespace; any other keyword is skipped; a non-keyword is a
|
;; its namespace; any other keyword is skipped; a non-keyword is a
|
||||||
;; nested binding pattern.
|
;; nested binding pattern.
|
||||||
|
|
@ -262,9 +291,12 @@
|
||||||
(if (keyword? k)
|
(if (keyword? k)
|
||||||
(let* [kn (name k) kns (namespace k)]
|
(let* [kn (name k) kns (namespace k)]
|
||||||
(cond
|
(cond
|
||||||
(and kns (= kn "keys")) (group a (get pat k) :kw kns)
|
(and kns (= kn "keys")) (group a (get pat k) :kw kns false)
|
||||||
(and kns (= kn "strs")) (group a (get pat k) :str kns)
|
(and kns (= kn "strs")) (group a (get pat k) :str kns false)
|
||||||
(and kns (= kn "syms")) (group a (get pat k) :sym kns)
|
(and kns (= kn "syms")) (group a (get pat k) :sym kns false)
|
||||||
|
(and kns (= kn "keys!")) (group a (get pat k) :kw kns true)
|
||||||
|
(and kns (= kn "strs!")) (group a (get pat k) :str kns true)
|
||||||
|
(and kns (= kn "syms!")) (group a (get pat k) :sym kns true)
|
||||||
:else a))
|
:else a))
|
||||||
;; a direct binding {x :x}: apply its :or default
|
;; a direct binding {x :x}: apply its :or default
|
||||||
;; (keyed by the local symbol) when the key is absent.
|
;; (keyed by the local symbol) when the key is absent.
|
||||||
|
|
@ -273,7 +305,7 @@
|
||||||
`(get ~gm ~(get pat k) ~(nth fo 1))
|
`(get ~gm ~(get pat k) ~(nth fo 1))
|
||||||
`(get ~gm ~(get pat k)))
|
`(get ~gm ~(get pat k)))
|
||||||
a))))
|
a))))
|
||||||
g3 (keys pat)))
|
g6 (keys pat)))
|
||||||
:else (throw (str "unsupported destructuring pattern: " (pr-str pat)))))
|
:else (throw (str "unsupported destructuring pattern: " (pr-str pat)))))
|
||||||
ploop
|
ploop
|
||||||
(fn* ploop [i acc]
|
(fn* ploop [i acc]
|
||||||
|
|
|
||||||
|
|
@ -66,9 +66,10 @@
|
||||||
\backspace "backspace" \space "space"})
|
\backspace "backspace" \space "space"})
|
||||||
(defn char-name-string [c] (get char-name-strings c))
|
(defn char-name-string [c] (get char-name-strings c))
|
||||||
|
|
||||||
;; Random selection over the host rand primitives.
|
;; Random selection over the host rand primitives — the reference shape:
|
||||||
|
;; nth directly (nil returns nil via RT.nth; a set throws like the JVM).
|
||||||
(defn rand-nth [coll]
|
(defn rand-nth [coll]
|
||||||
(let [v (vec coll)] (nth v (rand-int (count v)))))
|
(nth coll (rand-int (count coll))))
|
||||||
|
|
||||||
(defn random-sample
|
(defn random-sample
|
||||||
([prob] (filter (fn [_] (< (rand) prob))))
|
([prob] (filter (fn [_] (< (rand) prob))))
|
||||||
|
|
|
||||||
|
|
@ -89,6 +89,21 @@
|
||||||
(recur nxt (next ks))))
|
(recur nxt (next ks))))
|
||||||
m)))))
|
m)))))
|
||||||
|
|
||||||
|
(defn req!
|
||||||
|
"Returns the value mapped to key k in map m, like `get`, but throws
|
||||||
|
IllegalArgumentException when k is not present. Unlike `get`, does not nil-pun:
|
||||||
|
a key present with a nil value returns nil, an absent key throws. The primitive
|
||||||
|
behind checked-keys destructuring (:keys! / :syms! / :strs!)."
|
||||||
|
{:added "1.13"}
|
||||||
|
[m k]
|
||||||
|
;; a fresh map is its own identity, so a present-but-nil value is distinguished
|
||||||
|
;; from an absent key (same trick as get-in's sentinel).
|
||||||
|
(let [sentinel (hash-map)
|
||||||
|
v (get m k sentinel)]
|
||||||
|
(if (identical? sentinel v)
|
||||||
|
(throw (new IllegalArgumentException (str "Expected key: " k)))
|
||||||
|
v)))
|
||||||
|
|
||||||
;; find-based, so nil RESULTS are cached too; args canonicalize as a collection key.
|
;; find-based, so nil RESULTS are cached too; args canonicalize as a collection key.
|
||||||
(defn memoize [f]
|
(defn memoize [f]
|
||||||
(let [mem (atom (hash-map))]
|
(let [mem (atom (hash-map))]
|
||||||
|
|
|
||||||
|
|
@ -172,6 +172,14 @@
|
||||||
(def var-cache? (atom false))
|
(def var-cache? (atom false))
|
||||||
(defn set-var-cache! [on] (reset! var-cache? on))
|
(defn set-var-cache! [on] (reset! var-cache? on))
|
||||||
|
|
||||||
|
;; Opt-in tail-frame history (JOLT_TRACE): emit a (jolt-trace-push! "name") at the
|
||||||
|
;; head of every named fn body, so an entry records the frame into the runtime ring
|
||||||
|
;; buffer (rt.ss) and a TCO-elided frame still shows in an error's backtrace. OFF
|
||||||
|
;; during the seed mint and `jolt build` (byte-determinism + no runtime cost);
|
||||||
|
;; compile-eval.ss turns it on for runtime-eval'd user code when JOLT_TRACE is set.
|
||||||
|
(def trace-frames? (atom false))
|
||||||
|
(defn set-trace-frames! [on] (reset! trace-frames? on))
|
||||||
|
|
||||||
;; A direct-link Scheme binding name for a var. The fqn maps to a unique identifier
|
;; A direct-link Scheme binding name for a var. The fqn maps to a unique identifier
|
||||||
;; jv$<ns>$<name>; chars that break a Scheme identifier or the `$` separator are
|
;; jv$<ns>$<name>; chars that break a Scheme identifier or the `$` separator are
|
||||||
;; escaped so distinct vars never collide.
|
;; escaped so distinct vars never collide.
|
||||||
|
|
@ -191,6 +199,13 @@
|
||||||
;; recursion auto-restores them (no manual save/restore, no throw-leak).
|
;; recursion auto-restores them (no manual save/restore, no throw-leak).
|
||||||
(def ^:dynamic *recur-target* nil)
|
(def ^:dynamic *recur-target* nil)
|
||||||
(def ^:dynamic *known-procs* #{})
|
(def ^:dynamic *known-procs* #{})
|
||||||
|
;; True while emitting a node in TAIL position. Only used, in trace mode, to mark a
|
||||||
|
;; tail call so the runtime routes its callee into the current history rib instead
|
||||||
|
;; of a new one (rt.ss). It never affects semantics — a wrong value only mislabels
|
||||||
|
;; a debug trace line — so partial propagation is safe. `emit` (the wrapper below)
|
||||||
|
;; clears it by default; the tail-transparent forms (fn body, if/do/let/loop) pass
|
||||||
|
;; it to their tail child. Default false so a top-level form is treated non-tail.
|
||||||
|
(def ^:dynamic *tail?* false)
|
||||||
|
|
||||||
(def ^:private gensym-counter (atom 0))
|
(def ^:private gensym-counter (atom 0))
|
||||||
(defn- fresh-label [prefix] (str prefix (swap! gensym-counter inc)))
|
(defn- fresh-label [prefix] (str prefix (swap! gensym-counter inc)))
|
||||||
|
|
@ -253,6 +268,17 @@
|
||||||
(if (or (contains? scheme-reserved s) (contains? bare-native-names s)) (str "_" s) s)))
|
(if (or (contains? scheme-reserved s) (contains? bare-native-names s)) (str "_" s) s)))
|
||||||
|
|
||||||
(declare emit)
|
(declare emit)
|
||||||
|
(declare emit*)
|
||||||
|
;; Ops that pass tail position through to a child (the child can itself be a tail
|
||||||
|
;; call): if/do carry it to their tail branch/last form, let/loop to their body,
|
||||||
|
;; and invoke reads it to decide whether the call is tail. Every other op's
|
||||||
|
;; children are non-tail, so `emit` clears *tail?* before dispatching them — that
|
||||||
|
;; way a stray true can't leak into, say, a call sitting in a vector literal.
|
||||||
|
(def ^:private tail-transparent-ops #{:if :do :let :loop :invoke})
|
||||||
|
(defn emit [node]
|
||||||
|
(if (and *tail?* (not (tail-transparent-ops (:op node))))
|
||||||
|
(binding [*tail?* false] (emit* node))
|
||||||
|
(emit* node)))
|
||||||
|
|
||||||
;; A Chez string literal. Every char outside printable ASCII becomes a
|
;; A Chez string literal. Every char outside printable ASCII becomes a
|
||||||
;; codepoint hex escape \x<cp>; ; the named escapes (\n \t \r \" \\) match what
|
;; codepoint hex escape \x<cp>; ; the named escapes (\n \t \r \" \\) match what
|
||||||
|
|
@ -413,9 +439,10 @@
|
||||||
;; letfn lowers to a :let flagged :letrec (mutually-recursive named local fns):
|
;; letfn lowers to a :let flagged :letrec (mutually-recursive named local fns):
|
||||||
;; Scheme `letrec*` binds them so each sees its siblings. A plain let uses let*.
|
;; Scheme `letrec*` binds them so each sees its siblings. A plain let uses let*.
|
||||||
(defn- emit-let [node]
|
(defn- emit-let [node]
|
||||||
(let [kw (if (:letrec node) "letrec*" "let*")]
|
(let [kw (if (:letrec node) "letrec*" "let*")
|
||||||
(str "(" kw " (" (str/join " " (map emit-binding (:bindings node))) ") "
|
;; bindings are non-tail; the body inherits the let's tail position
|
||||||
(emit (:body node)) ")")))
|
binds (binding [*tail?* false] (str/join " " (mapv emit-binding (:bindings node))))]
|
||||||
|
(str "(" kw " (" binds ") " (emit (:body node)) ")")))
|
||||||
|
|
||||||
(defn- emit-loop [node]
|
(defn- emit-loop [node]
|
||||||
(let [label (fresh-label "loop")
|
(let [label (fresh-label "loop")
|
||||||
|
|
@ -423,9 +450,10 @@
|
||||||
names (map #(munge-name (nth % 0)) pairs)
|
names (map #(munge-name (nth % 0)) pairs)
|
||||||
;; inits evaluate in the OUTER scope (recur-target unchanged) and, like
|
;; inits evaluate in the OUTER scope (recur-target unchanged) and, like
|
||||||
;; Clojure loop/let, SEQUENTIALLY — wrap a let* around the named let.
|
;; Clojure loop/let, SEQUENTIALLY — wrap a let* around the named let.
|
||||||
inits (map #(emit (nth % 1)) pairs)
|
inits (binding [*tail?* false] (mapv #(emit (nth % 1)) pairs))
|
||||||
seq-bs (str/join " " (map (fn [n i] (str "(" n " " i ")")) names inits))
|
seq-bs (str/join " " (map (fn [n i] (str "(" n " " i ")")) names inits))
|
||||||
rebinds (str/join " " (map (fn [n] (str "(" n " " n ")")) names))
|
rebinds (str/join " " (map (fn [n] (str "(" n " " n ")")) names))
|
||||||
|
;; the loop body inherits the loop's tail position
|
||||||
body (binding [*recur-target* label] (emit (:body node)))]
|
body (binding [*recur-target* label] (emit (:body node)))]
|
||||||
(str "(let* (" seq-bs ") (let " label " (" rebinds ") " body "))")))
|
(str "(let* (" seq-bs ") (let " label " (" rebinds ") " body "))")))
|
||||||
|
|
||||||
|
|
@ -486,7 +514,11 @@
|
||||||
params (map munge-name orig)
|
params (map munge-name orig)
|
||||||
restp (when-let [r (:rest a)] (munge-name r))
|
restp (when-let [r (:rest a)] (munge-name r))
|
||||||
label (fresh-label "fnrec")
|
label (fresh-label "fnrec")
|
||||||
body (binding [*recur-target* label] (emit (:body a)))
|
ret (:ret-nhint a)
|
||||||
|
;; the body is the fn's tail position — UNLESS a ^double/^long return hint
|
||||||
|
;; wraps it in a coercion below, which puts the body back in non-tail.
|
||||||
|
body-tail? (not (or (= ret :double) (= ret :long)))
|
||||||
|
body (binding [*recur-target* label *tail?* body-tail?] (emit (:body a)))
|
||||||
paramlist (cond
|
paramlist (cond
|
||||||
(and restp (empty? params)) restp
|
(and restp (empty? params)) restp
|
||||||
restp (str "(" (str/join " " params) " . " restp ")")
|
restp (str "(" (str/join " " params) " . " restp ")")
|
||||||
|
|
@ -511,6 +543,16 @@
|
||||||
self (when-let [nm (:name node)] (munge-name nm))
|
self (when-let [nm (:name node)] (munge-name nm))
|
||||||
clauses (binding [*known-procs* (if self (conj *known-procs* self) *known-procs*)]
|
clauses (binding [*known-procs* (if self (conj *known-procs* self) *known-procs*)]
|
||||||
(mapv emit-arity-clause arities))
|
(mapv emit-arity-clause arities))
|
||||||
|
;; trace mode: record this frame on entry (before the body), so a frame
|
||||||
|
;; the body then tail-calls away is still in the ring at throw time. A
|
||||||
|
;; `recur` re-enters via the named-let, not the lambda, so a tight loop
|
||||||
|
;; records once, not per iteration.
|
||||||
|
clauses (if (and @trace-frames? self)
|
||||||
|
(mapv (fn [c] [(nth c 0)
|
||||||
|
(str "(begin (jolt-trace-push! " (chez-str-lit self) ") "
|
||||||
|
(nth c 1) ")")])
|
||||||
|
clauses)
|
||||||
|
clauses)
|
||||||
lambda (if (= 1 (count clauses))
|
lambda (if (= 1 (count clauses))
|
||||||
(let [c (first clauses)] (str "(lambda " (nth c 0) " " (nth c 1) ")"))
|
(let [c (first clauses)] (str "(lambda " (nth c 0) " " (nth c 1) ")"))
|
||||||
(str "(case-lambda "
|
(str "(case-lambda "
|
||||||
|
|
@ -573,7 +615,30 @@
|
||||||
(= (nth shape i) kw) i
|
(= (nth shape i) kw) i
|
||||||
:else (recur (inc i))))))
|
:else (recur (inc i))))))
|
||||||
|
|
||||||
|
;; A plain Scheme application: (callee op ...).
|
||||||
|
(defn- plain-call [callee operand-strs]
|
||||||
|
(str "(" callee (if (seq operand-strs) (str " " (str/join " " operand-strs)) "") ")"))
|
||||||
|
;; A tail call in trace mode. Force-bind the operands to temps FIRST (so any
|
||||||
|
;; operand whose own evaluation records a trace entry runs before our mark), THEN
|
||||||
|
;; set the tail mark, THEN apply — the callee's entry prologue consumes the mark
|
||||||
|
;; with nothing in between, so it can't be clobbered. Still a tail call: the let*'s
|
||||||
|
;; last form is the application, so TCO is preserved.
|
||||||
|
(defn- tail-marked-call [callee operand-strs]
|
||||||
|
(let [tmps (mapv (fn [_] (fresh-label "_tt$")) operand-strs)
|
||||||
|
binds (str/join " " (map (fn [t a] (str "(" t " " a ")")) tmps operand-strs))]
|
||||||
|
(str "(let* (" binds ") (jolt-trace-mark! #t) " (plain-call callee tmps) ")")))
|
||||||
|
;; Emit a call, tail-marked when we're in tail position and tracing is on; a plain
|
||||||
|
;; application otherwise. The mark is consumed by the callee's entry prologue —
|
||||||
|
;; direct calls (:local known-proc, direct-link) always have one; a jolt-invoke
|
||||||
|
;; call usually reaches one but not always (see the best-effort note in rt.ss).
|
||||||
|
(defn- emit-call [tail? callee operand-strs]
|
||||||
|
(if (and @trace-frames? tail?)
|
||||||
|
(tail-marked-call callee operand-strs)
|
||||||
|
(plain-call callee operand-strs)))
|
||||||
|
|
||||||
(defn- emit-invoke [node]
|
(defn- emit-invoke [node]
|
||||||
|
(let [tail? *tail?*] ; capture: children below emit non-tail
|
||||||
|
(binding [*tail?* false]
|
||||||
(let [fnode (:fn node)
|
(let [fnode (:fn node)
|
||||||
arg-nodes (:args node)
|
arg-nodes (:args node)
|
||||||
args (mapv emit arg-nodes)
|
args (mapv emit arg-nodes)
|
||||||
|
|
@ -586,8 +651,7 @@
|
||||||
;; order [callee & args] together when ordering is observable.
|
;; order [callee & args] together when ordering is observable.
|
||||||
invoke (fn []
|
invoke (fn []
|
||||||
(ordered-call (cons fnode arg-nodes) (cons (emit fnode) args)
|
(ordered-call (cons fnode arg-nodes) (cons (emit fnode) args)
|
||||||
(fn [[f & as]]
|
(fn [operands] (emit-call tail? "jolt-invoke" operands))))]
|
||||||
(str "(jolt-invoke " f (if (seq as) (str " " (str/join " " as)) "") ")"))))]
|
|
||||||
(cond
|
(cond
|
||||||
;; devirtualized protocol call: the inference proved the receiver (arg 0) is
|
;; devirtualized protocol call: the inference proved the receiver (arg 0) is
|
||||||
;; one record type, so resolve the impl by that static tag instead of routing
|
;; one record type, so resolve the impl by that static tag instead of routing
|
||||||
|
|
@ -662,8 +726,7 @@
|
||||||
;; holds an arbitrary IFn -> dynamic dispatch.
|
;; holds an arbitrary IFn -> dynamic dispatch.
|
||||||
(= :local (:op fnode))
|
(= :local (:op fnode))
|
||||||
(if (*known-procs* (munge-name (:name fnode)))
|
(if (*known-procs* (munge-name (:name fnode)))
|
||||||
(order-args (fn [as] (str "(" (munge-name (:name fnode))
|
(order-args (fn [as] (emit-call tail? (munge-name (:name fnode)) as)))
|
||||||
(if (seq as) (str " " (str/join " " as)) "") ")")))
|
|
||||||
(invoke))
|
(invoke))
|
||||||
;; closed-world direct call: the callee var is an app fn def already emitted
|
;; closed-world direct call: the callee var is an app fn def already emitted
|
||||||
;; with a Scheme binding — apply it directly, no var lookup, no jolt-invoke.
|
;; with a Scheme binding — apply it directly, no var lookup, no jolt-invoke.
|
||||||
|
|
@ -672,8 +735,7 @@
|
||||||
;; below (which still uses the direct binding as the invoke target).
|
;; below (which still uses the direct binding as the invoke target).
|
||||||
(and (= :var (:op fnode)) (direct-linkable? (:ns fnode) (:name fnode))
|
(and (= :var (:op fnode)) (direct-linkable? (:ns fnode) (:name fnode))
|
||||||
(direct-link-fn? (:ns fnode) (:name fnode)))
|
(direct-link-fn? (:ns fnode) (:name fnode)))
|
||||||
(order-args (fn [as] (str "(" (dl-name (:ns fnode) (:name fnode))
|
(order-args (fn [as] (emit-call tail? (dl-name (:ns fnode) (:name fnode)) as)))
|
||||||
(if (seq as) (str " " (str/join " " as)) "") ")")))
|
|
||||||
;; a late-bound :var call head can hold a procedure OR a non-applicable
|
;; a late-bound :var call head can hold a procedure OR a non-applicable
|
||||||
;; value the RT dispatches (multimethod, keyword/coll IFn) — route via
|
;; value the RT dispatches (multimethod, keyword/coll IFn) — route via
|
||||||
;; jolt-invoke (transparent for a procedure).
|
;; jolt-invoke (transparent for a procedure).
|
||||||
|
|
@ -681,7 +743,7 @@
|
||||||
(invoke)
|
(invoke)
|
||||||
;; a computed callee can yield ANY IFn — route through jolt-invoke.
|
;; a computed callee can yield ANY IFn — route through jolt-invoke.
|
||||||
:else
|
:else
|
||||||
(invoke))))
|
(invoke))))))
|
||||||
|
|
||||||
;; try/catch/finally. throw raises a Chez condition wrapping the jolt value
|
;; try/catch/finally. throw raises a Chez condition wrapping the jolt value
|
||||||
;; (jolt-throw = Scheme `raise` of a &jolt-throw condition); catch lowers to
|
;; (jolt-throw = Scheme `raise` of a &jolt-throw condition); catch lowers to
|
||||||
|
|
@ -728,7 +790,22 @@
|
||||||
(returns-scheme-bool? (:body node) bools'))
|
(returns-scheme-bool? (:body node) bools'))
|
||||||
:else false)))
|
:else false)))
|
||||||
|
|
||||||
(defn emit [node]
|
;; In trace mode, a fn def also registers its source so the tail-frame history maps
|
||||||
|
;; the recorded frame-name to "ns/name (file:line)" instead of a bare name. Keyed by
|
||||||
|
;; the SAME munged name the entry push records (emit-fn's letrec self-binding = the
|
||||||
|
;; fn's own name). Returns "" when off / not a positioned fn def, so trace-off output
|
||||||
|
;; (seed mint, `jolt build`) is byte-identical. Direct-link builds already register
|
||||||
|
;; via emit-def-cached; this covers the open-world eval path.
|
||||||
|
(defn- trace-source-reg [node]
|
||||||
|
(let [init (:init node) pos (:pos node)]
|
||||||
|
(if (and @trace-frames? (= :fn (:op init)) (:name init) pos)
|
||||||
|
(str " (jolt-register-source! " (chez-str-lit (munge-name (:name init))) " "
|
||||||
|
(chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) " "
|
||||||
|
(if (:file pos) (chez-str-lit (:file pos)) "jolt-nil") " "
|
||||||
|
(or (:line pos) 0) ")")
|
||||||
|
"")))
|
||||||
|
|
||||||
|
(defn emit* [node]
|
||||||
(case (:op node)
|
(case (:op node)
|
||||||
:const (emit-const (:val node))
|
:const (emit-const (:val node))
|
||||||
:local (munge-name (:name node))
|
:local (munge-name (:name node))
|
||||||
|
|
@ -776,11 +853,14 @@
|
||||||
:host-new (str "(host-new " (chez-str-lit (:class node))
|
:host-new (str "(host-new " (chez-str-lit (:class node))
|
||||||
(let [args (map emit (:args node))]
|
(let [args (map emit (:args node))]
|
||||||
(if (empty? args) "" (str " " (str/join " " args)))) ")")
|
(if (empty? args) "" (str " " (str/join " " args)))) ")")
|
||||||
|
;; the test is non-tail; then/else inherit the if's tail position
|
||||||
:if (let [test (:test node)
|
:if (let [test (:test node)
|
||||||
t (if (returns-scheme-bool? test) (emit test)
|
t (binding [*tail?* false]
|
||||||
(str "(jolt-truthy? " (emit test) ")"))]
|
(if (returns-scheme-bool? test) (emit test)
|
||||||
|
(str "(jolt-truthy? " (emit test) ")")))]
|
||||||
(str "(if " t " " (emit (:then node)) " " (emit (:else node)) ")"))
|
(str "(if " t " " (emit (:then node)) " " (emit (:else node)) ")"))
|
||||||
:do (str "(begin " (str/join " " (map emit (:statements node)))
|
;; non-last statements are non-tail; the ret inherits the do's tail position
|
||||||
|
:do (str "(begin " (binding [*tail?* false] (str/join " " (mapv emit (:statements node))))
|
||||||
(if (empty? (:statements node)) "" " ") (emit (:ret node)) ")")
|
(if (empty? (:statements node)) "" " ") (emit (:ret node)) ")")
|
||||||
:invoke (emit-invoke node)
|
:invoke (emit-invoke node)
|
||||||
;; collection literals -> rt constructors (collections.ss). Elements are
|
;; collection literals -> rt constructors (collections.ss). Elements are
|
||||||
|
|
@ -824,7 +904,8 @@
|
||||||
:fn (emit-fn node)
|
:fn (emit-fn node)
|
||||||
;; (def name) with no init (declare): reserve the cell. A def with non-empty
|
;; (def name) with no init (declare): reserve the cell. A def with non-empty
|
||||||
;; reader metadata lowers to def-var-with-meta! (ported in a later increment).
|
;; reader metadata lowers to def-var-with-meta! (ported in a later increment).
|
||||||
:def (cond
|
:def (let [reg (trace-source-reg node)
|
||||||
|
d (cond
|
||||||
(:no-init node)
|
(:no-init node)
|
||||||
(str "(declare-var! " (chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) ")")
|
(str "(declare-var! " (chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) ")")
|
||||||
(jmeta-nonempty? (:meta node))
|
(jmeta-nonempty? (:meta node))
|
||||||
|
|
@ -832,7 +913,8 @@
|
||||||
(emit-with-cells #(emit (:init node))) " " (emit-def-meta node) ")")
|
(emit-with-cells #(emit (:init node))) " " (emit-def-meta node) ")")
|
||||||
:else
|
:else
|
||||||
(str "(def-var! " (chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) " "
|
(str "(def-var! " (chez-str-lit (:ns node)) " " (chez-str-lit (:name node)) " "
|
||||||
(emit-with-cells #(emit (:init node))) ")"))
|
(emit-with-cells #(emit (:init node))) ")"))]
|
||||||
|
(if (= reg "") d (str "(begin " d reg ")")))
|
||||||
(throw (ex-info (str "emit: op not yet ported / unhandled: " (pr-str (:op node))) {}))))
|
(throw (ex-info (str "emit: op not yet ported / unhandled: " (pr-str (:op node))) {}))))
|
||||||
|
|
||||||
;; ^:dynamic / ^:redef on a def opts it out of direct-linking: it stays redefinable,
|
;; ^:dynamic / ^:redef on a def opts it out of direct-linking: it stays redefinable,
|
||||||
|
|
|
||||||
|
|
@ -66,6 +66,10 @@
|
||||||
(if-let [root (:deps/root spec)] (str checkout "/" root) checkout))
|
(if-let [root (:deps/root spec)] (str checkout "/" root) checkout))
|
||||||
(:jolt/module spec)
|
(:jolt/module spec)
|
||||||
(do (warn "skipping janet dependency " coord " (:jolt/module is obsolete on Chez)") nil)
|
(do (warn "skipping janet dependency " coord " (:jolt/module is obsolete on Chez)") nil)
|
||||||
|
;; jolt IS Clojure — a dependency on org.clojure/clojure is satisfied
|
||||||
|
;; intrinsically, so skip it silently rather than warning about the (unusable)
|
||||||
|
;; :mvn/version coordinate.
|
||||||
|
(= coord 'org.clojure/clojure) nil
|
||||||
:else
|
:else
|
||||||
(do (warn "skipping unsupported coordinate " coord " " (pr-str spec)) nil)))
|
(do (warn "skipping unsupported coordinate " coord " " (pr-str spec)) nil)))
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -8,6 +8,8 @@
|
||||||
|
|
||||||
(defn- project-dir [] (or (jolt.host/getenv "JOLT_PWD") "."))
|
(defn- project-dir [] (or (jolt.host/getenv "JOLT_PWD") "."))
|
||||||
|
|
||||||
|
(defn- version [] (jolt.host/jolt-version))
|
||||||
|
|
||||||
(defn- current-platform []
|
(defn- current-platform []
|
||||||
(let [os (str/lower-case (or (System/getProperty "os.name") ""))]
|
(let [os (str/lower-case (or (System/getProperty "os.name") ""))]
|
||||||
(cond (str/includes? os "mac") :darwin
|
(cond (str/includes? os "mac") :darwin
|
||||||
|
|
@ -145,7 +147,10 @@
|
||||||
;; loaded — same context a run gets, so (require '[some.lib]) works in the REPL.
|
;; loaded — same context a run gets, so (require '[some.lib]) works in the REPL.
|
||||||
(try (apply-project! (deps/resolve-project (project-dir)))
|
(try (apply-project! (deps/resolve-project (project-dir)))
|
||||||
(catch :default _ nil))
|
(catch :default _ nil))
|
||||||
(println ";; jolt repl — :repl/quit or ^D to exit")
|
;; REPL-driven development: trace by default so an uncaught error in evaluated
|
||||||
|
;; code shows a tail-frame backtrace, no JOLT_TRACE needed (JOLT_TRACE=0 opts out).
|
||||||
|
(jolt.host/enable-trace!)
|
||||||
|
(println (str ";; jolt " (version) " repl — :repl/quit or ^D to exit"))
|
||||||
(loop []
|
(loop []
|
||||||
(let [form (repl-read-form)]
|
(let [form (repl-read-form)]
|
||||||
(when form
|
(when form
|
||||||
|
|
@ -158,7 +163,9 @@
|
||||||
(catch :default e
|
(catch :default e
|
||||||
(println "error:" (or (ex-message e)
|
(println "error:" (or (ex-message e)
|
||||||
(try ((resolve 'jolt.host/condition-message) e) (catch :default _ nil))
|
(try ((resolve 'jolt.host/condition-message) e) (catch :default _ nil))
|
||||||
(pr-str e)))))
|
(pr-str e)))
|
||||||
|
(when-let [bt (jolt.host/backtrace-string)]
|
||||||
|
(print bt))))
|
||||||
(recur)))))))
|
(recur)))))))
|
||||||
|
|
||||||
;; A deps.edn :tasks entry: a string is a shell command; a map is {:main-opts …}.
|
;; A deps.edn :tasks entry: a string is a shell command; a map is {:main-opts …}.
|
||||||
|
|
@ -294,7 +301,9 @@
|
||||||
(when stop (stop))))))
|
(when stop (stop))))))
|
||||||
|
|
||||||
(defn- usage []
|
(defn- usage []
|
||||||
|
(println (str "jolt " (version)))
|
||||||
(println "usage: jolt <command> [args]")
|
(println "usage: jolt <command> [args]")
|
||||||
|
(println " -e EXPR evaluate EXPR and print the result")
|
||||||
(println " run -m NS [args] resolve deps.edn, load NS, call its -main")
|
(println " run -m NS [args] resolve deps.edn, load NS, call its -main")
|
||||||
(println " run FILE load a Clojure file")
|
(println " run FILE load a Clojure file")
|
||||||
(println " build -m NS [-o OUT] [--opt|--dev] [--direct-link] [--tree-shake] [--dynamic] compile a standalone binary")
|
(println " build -m NS [-o OUT] [--opt|--dev] [--direct-link] [--tree-shake] [--dynamic] compile a standalone binary")
|
||||||
|
|
@ -304,6 +313,7 @@
|
||||||
(println " --nrepl-server [port] start an nREPL server (default 7888) for editors")
|
(println " --nrepl-server [port] start an nREPL server (default 7888) for editors")
|
||||||
(println " path print the resolved source roots")
|
(println " path print the resolved source roots")
|
||||||
(println " <task> run a deps.edn :tasks entry")
|
(println " <task> run a deps.edn :tasks entry")
|
||||||
|
(println " --version print the jolt version")
|
||||||
(println " --help print this message"))
|
(println " --help print this message"))
|
||||||
|
|
||||||
(defn -main [& args]
|
(defn -main [& args]
|
||||||
|
|
@ -312,6 +322,7 @@
|
||||||
(nil? cmd) (usage)
|
(nil? cmd) (usage)
|
||||||
(= cmd "--help") (usage)
|
(= cmd "--help") (usage)
|
||||||
(= cmd "-h") (usage)
|
(= cmd "-h") (usage)
|
||||||
|
(#{"--version" "-V"} cmd) (println (str "jolt " (version)))
|
||||||
(= cmd "run") (cmd-run more)
|
(= cmd "run") (cmd-run more)
|
||||||
(= cmd "repl") (repl)
|
(= cmd "repl") (repl)
|
||||||
(= cmd "--nrepl-server") (nrepl more)
|
(= cmd "--nrepl-server") (nrepl more)
|
||||||
|
|
|
||||||
|
|
@ -21,25 +21,66 @@
|
||||||
[jolt.ffi :as ffi]))
|
[jolt.ffi :as ffi]))
|
||||||
|
|
||||||
;; --- sockets (loopback server) ---------------------------------------------
|
;; --- sockets (loopback server) ---------------------------------------------
|
||||||
;; Load libc (the running process's symbols) BEFORE the foreign-fn bindings below
|
(def ^:private os-name
|
||||||
;; — defcfn resolves the C entry point when the def is evaluated (at ns load), so
|
(str/lower-case (or (System/getProperty "os.name") "")))
|
||||||
;; the socket symbols must already be available.
|
(def ^:private macos? (str/includes? os-name "mac"))
|
||||||
(ffi/load-library)
|
(def ^:private windows? (str/includes? os-name "win"))
|
||||||
|
|
||||||
|
;; Load the library that provides the socket symbols BEFORE the foreign-fn
|
||||||
|
;; bindings below — defcfn resolves the C entry point when the def is evaluated
|
||||||
|
;; (at ns load), so the symbols must already be available. POSIX: the running
|
||||||
|
;; process's own libc symbols. Windows: the Winsock DLL (ws2_32), whose symbols
|
||||||
|
;; are NOT in joltc.exe's export table even though it's linked in — without this
|
||||||
|
;; explicit load, (ffi/defcfn c-socket "socket" ...) fails at load with
|
||||||
|
;; "no entry for socket".
|
||||||
|
(if windows?
|
||||||
|
(ffi/load-library "ws2_32.dll")
|
||||||
|
(ffi/load-library))
|
||||||
|
|
||||||
|
;; A socket is an int fd on POSIX; on Win64 it's a SOCKET (uintptr_t) handle, but
|
||||||
|
;; those are small kernel handle values that round-trip through :int, and the
|
||||||
|
;; INVALID_SOCKET error sentinel (~0) reads back as -1 — so the fd checks below
|
||||||
|
;; work unchanged on both.
|
||||||
(ffi/defcfn c-socket "socket" [:int :int :int] :int)
|
(ffi/defcfn c-socket "socket" [:int :int :int] :int)
|
||||||
(ffi/defcfn c-bind "bind" [:int :pointer :int] :int)
|
(ffi/defcfn c-bind "bind" [:int :pointer :int] :int)
|
||||||
(ffi/defcfn c-listen "listen" [:int :int] :int)
|
(ffi/defcfn c-listen "listen" [:int :int] :int)
|
||||||
(ffi/defcfn c-setsockopt "setsockopt" [:int :int :int :pointer :int] :int)
|
(ffi/defcfn c-setsockopt "setsockopt" [:int :int :int :pointer :int] :int)
|
||||||
(ffi/defcfn c-accept "accept" [:int :pointer :pointer] :int :blocking)
|
(ffi/defcfn c-accept "accept" [:int :pointer :pointer] :int :blocking)
|
||||||
|
|
||||||
|
;; recv/send and the socket-close call differ by platform. Winsock's recv/send
|
||||||
|
;; take an int length and return int (not ssize_t), and a socket is closed with
|
||||||
|
;; closesocket, not close. A symbol that exists on only one OS (closesocket on
|
||||||
|
;; Windows, close on POSIX) can only be bound there, so these live in the taken
|
||||||
|
;; platform branch — jolt interns the vars from both branches at analysis time,
|
||||||
|
;; so later references resolve either way.
|
||||||
|
(if windows?
|
||||||
|
(do
|
||||||
|
(ffi/defcfn c-recv "recv" [:int :pointer :int :int] :int :blocking)
|
||||||
|
(ffi/defcfn c-send "send" [:int :pointer :int :int] :int :blocking)
|
||||||
|
(ffi/defcfn c-close "closesocket" [:int] :int)
|
||||||
|
;; Winsock must be initialized once per process before any socket call.
|
||||||
|
(ffi/defcfn c-wsastartup "WSAStartup" [:int :pointer] :int))
|
||||||
|
(do
|
||||||
(ffi/defcfn c-recv "recv" [:int :pointer :size_t :int] :ssize_t :blocking)
|
(ffi/defcfn c-recv "recv" [:int :pointer :size_t :int] :ssize_t :blocking)
|
||||||
(ffi/defcfn c-send "send" [:int :pointer :size_t :int] :ssize_t :blocking)
|
(ffi/defcfn c-send "send" [:int :pointer :size_t :int] :ssize_t :blocking)
|
||||||
(ffi/defcfn c-close "close" [:int] :int)
|
(ffi/defcfn c-close "close" [:int] :int)))
|
||||||
|
|
||||||
(def ^:private AF-INET 2)
|
(def ^:private AF-INET 2)
|
||||||
(def ^:private SOCK-STREAM 1)
|
(def ^:private SOCK-STREAM 1)
|
||||||
(def ^:private macos?
|
;; SOL_SOCKET / SO_REUSEADDR: 0xffff / 4 on macOS and Windows, 1 / 2 on Linux.
|
||||||
(str/includes? (str/lower-case (or (System/getProperty "os.name") "")) "mac"))
|
(def ^:private sol-socket (if (or macos? windows?) 0xffff 1))
|
||||||
(def ^:private sol-socket (if macos? 0xffff 1))
|
(def ^:private so-reuse (if (or macos? windows?) 4 2))
|
||||||
(def ^:private so-reuse (if macos? 4 2))
|
|
||||||
|
;; Initialize Winsock (a no-op off Windows). WSAStartup is refcounted and must
|
||||||
|
;; precede any socket call; WSADATA is ~408 bytes on x64, so 512 is ample.
|
||||||
|
(defn- ensure-winsock! []
|
||||||
|
(when windows?
|
||||||
|
(let [wsadata (ffi/alloc 512)]
|
||||||
|
(try
|
||||||
|
(let [r (c-wsastartup 0x0202 wsadata)]
|
||||||
|
(when-not (zero? r)
|
||||||
|
(throw (ex-info (str "WSAStartup failed: " r) {}))))
|
||||||
|
(finally (ffi/free wsadata))))))
|
||||||
|
|
||||||
(defn- make-sockaddr [port]
|
(defn- make-sockaddr [port]
|
||||||
(let [sa (ffi/alloc 16)]
|
(let [sa (ffi/alloc 16)]
|
||||||
|
|
@ -53,7 +94,7 @@
|
||||||
sa))
|
sa))
|
||||||
|
|
||||||
(defn- listen-socket [port]
|
(defn- listen-socket [port]
|
||||||
(ffi/load-library) ; libc process symbols
|
(ensure-winsock!) ; no-op off Windows
|
||||||
(let [fd (c-socket AF-INET SOCK-STREAM 0)]
|
(let [fd (c-socket AF-INET SOCK-STREAM 0)]
|
||||||
(when (neg? fd) (throw (ex-info "socket() failed" {})))
|
(when (neg? fd) (throw (ex-info "socket() failed" {})))
|
||||||
(let [opt (ffi/alloc 4)] (ffi/write opt :int 0 1) (c-setsockopt fd sol-socket so-reuse opt 4) (ffi/free opt))
|
(let [opt (ffi/alloc 4)] (ffi/write opt :int 0 1) (c-setsockopt fd sol-socket so-reuse opt 4) (ffi/free opt))
|
||||||
|
|
@ -147,7 +188,10 @@
|
||||||
(try (when (and ns-str (not (str/blank? ns-str)) (find-ns (symbol ns-str)))
|
(try (when (and ns-str (not (str/blank? ns-str)) (find-ns (symbol ns-str)))
|
||||||
(in-ns (symbol ns-str)))
|
(in-ns (symbol ns-str)))
|
||||||
(reset! result (load-string code))
|
(reset! result (load-string code))
|
||||||
(catch :default e (reset! err (err-msg e)))))]
|
(catch :default e
|
||||||
|
(reset! err (str (err-msg e)
|
||||||
|
(when-let [bt (jolt.host/backtrace-string)]
|
||||||
|
(str "\n" bt)))))))]
|
||||||
{:value (when (nil? @err) (pr-str @result))
|
{:value (when (nil? @err) (pr-str @result))
|
||||||
:out out
|
:out out
|
||||||
:ns (str (ns-name *ns*))
|
:ns (str (ns-name *ns*))
|
||||||
|
|
@ -236,11 +280,17 @@
|
||||||
no-op."
|
no-op."
|
||||||
([port] (start port nil))
|
([port] (start port nil))
|
||||||
([port middleware]
|
([port middleware]
|
||||||
|
;; An nREPL session is REPL-driven development: trace by default so an uncaught
|
||||||
|
;; error in code evaluated over the connection shows a tail-frame backtrace, with
|
||||||
|
;; no JOLT_TRACE needed. Covers both `--nrepl-server` and an app that starts its
|
||||||
|
;; own server under `-M:run` (reload a namespace to trace already-loaded code).
|
||||||
|
(jolt.host/enable-trace!)
|
||||||
(let [handler (build-handler (resolve-middleware (or middleware [])))
|
(let [handler (build-handler (resolve-middleware (or middleware [])))
|
||||||
fd (listen-socket port) ; throws on bind/listen failure
|
fd (listen-socket port) ; throws on bind/listen failure
|
||||||
stopped (atom false)]
|
stopped (atom false)]
|
||||||
(try (spit ".nrepl-port" (str port)) (catch :default _ nil))
|
(try (spit ".nrepl-port" (str port)) (catch :default _ nil))
|
||||||
(println (str "nREPL server started on port " port " (127.0.0.1) — .nrepl-port written"))
|
(println (str "jolt " (jolt.host/jolt-version) " nREPL server started on port "
|
||||||
|
port " (127.0.0.1) — .nrepl-port written"))
|
||||||
(when (seq middleware) (println (str ";; middleware: " (str/join " " middleware))))
|
(when (seq middleware) (println (str ";; middleware: " (str/join " " middleware))))
|
||||||
(println ";; connect your editor; ^C to stop")
|
(println ";; connect your editor; ^C to stop")
|
||||||
(future
|
(future
|
||||||
|
|
|
||||||
|
|
@ -7,7 +7,7 @@ test` from the repo root.
|
||||||
|
|
||||||
## The spec corpus
|
## The spec corpus
|
||||||
|
|
||||||
`corpus.edn` is the contract: ~2920 rows `{:suite :label :expected :actual}`, with
|
`corpus.edn` is the contract: ~3570 rows `{:suite :label :expected :actual :portability}`, with
|
||||||
`:expected` sourced from reference JVM Clojure by `test/conformance/regen-corpus.clj`.
|
`:expected` sourced from reference JVM Clojure by `test/conformance/regen-corpus.clj`.
|
||||||
It is frozen (the canonical source) — add or change cases here, then re-source the
|
It is frozen (the canonical source) — add or change cases here, then re-source the
|
||||||
answers with `regen-corpus.clj` and re-certify with `test/conformance/certify.clj`.
|
answers with `regen-corpus.clj` and re-certify with `test/conformance/certify.clj`.
|
||||||
|
|
@ -22,7 +22,7 @@ answers with `regen-corpus.clj` and re-certify with `test/conformance/certify.cl
|
||||||
|
|
||||||
chez --script host/chez/run-corpus.ss
|
chez --script host/chez/run-corpus.ss
|
||||||
JOLT_CORPUS_LIMIT=200 … # every-Nth stride, fast iteration
|
JOLT_CORPUS_LIMIT=200 … # every-Nth stride, fast iteration
|
||||||
JOLT_CHEZ_ZJ_FLOOR=N … # override the floor (default 2678)
|
JOLT_CHEZ_ZJ_FLOOR=N … # override the floor (see run-corpus.ss)
|
||||||
|
|
||||||
- `run-unit.ss` — host-specific unit cases (`test/chez/unit.edn`) that aren't in the
|
- `run-unit.ss` — host-specific unit cases (`test/chez/unit.edn`) that aren't in the
|
||||||
JVM-portable corpus: dot-forms, java statics, io, reader, walk, vars/namespaces,
|
JVM-portable corpus: dot-forms, java statics, io, reader, walk, vars/namespaces,
|
||||||
|
|
|
||||||
|
|
@ -3583,4 +3583,5 @@
|
||||||
{:suite "contracts / misc" :label "vector invocation has nth semantics; run! honors reduced; eval self-evaluates values" :expected "[:ioob 1 true]" :actual "[(try ([1 2] 5) (catch IndexOutOfBoundsException _ :ioob)) (let [c (atom 0)] (run! (fn [x] (swap! c inc) (reduced x)) [1 2 3]) (deref c)) (fn? (eval +))]" :portability :common}
|
{:suite "contracts / misc" :label "vector invocation has nth semantics; run! honors reduced; eval self-evaluates values" :expected "[:ioob 1 true]" :actual "[(try ([1 2] 5) (catch IndexOutOfBoundsException _ :ioob)) (let [c (atom 0)] (run! (fn [x] (swap! c inc) (reduced x)) [1 2 3]) (deref c)) (fn? (eval +))]" :portability :common}
|
||||||
{:suite "contracts / misc" :label "intern demands an existing ns; counted? excludes strings; seqable? includes arrays" :expected "[:t false true]" :actual "[(try (intern (quote no-such-ns-xyz) (quote v) 1) (catch Throwable _ :t)) (counted? \"s\") (seqable? (object-array 2))]" :portability :jvm}
|
{:suite "contracts / misc" :label "intern demands an existing ns; counted? excludes strings; seqable? includes arrays" :expected "[:t false true]" :actual "[(try (intern (quote no-such-ns-xyz) (quote v) 1) (catch Throwable _ :t)) (counted? \"s\") (seqable? (object-array 2))]" :portability :jvm}
|
||||||
{:suite "contracts / misc" :label "nth of nil honors notFound; a nil index throws; the starred specials are special" :expected "[:default :npe [true true true true true]]" :actual "[(nth nil 5 :default) (try (nth [1] nil) (catch NullPointerException _ :npe)) [(special-symbol? (quote case*)) (special-symbol? (quote deftype*)) (special-symbol? (quote letfn*)) (special-symbol? (quote reify*)) (special-symbol? (quote &))]]" :portability :common}
|
{:suite "contracts / misc" :label "nth of nil honors notFound; a nil index throws; the starred specials are special" :expected "[:default :npe [true true true true true]]" :actual "[(nth nil 5 :default) (try (nth [1] nil) (catch NullPointerException _ :npe)) [(special-symbol? (quote case*)) (special-symbol? (quote deftype*)) (special-symbol? (quote letfn*)) (special-symbol? (quote reify*)) (special-symbol? (quote &))]]" :portability :common}
|
||||||
|
{:suite "contracts / misc" :label "rand-nth of nil is nil; of a set throws" :expected "[nil :t]" :actual "[(rand-nth nil) (try (rand-nth #{1 2}) (catch Throwable _ :t))]" :portability :common}
|
||||||
]
|
]
|
||||||
|
|
|
||||||
|
|
@ -23,7 +23,6 @@ clojure.core-test.plus 11 0
|
||||||
clojure.core-test.plus-squote 11 0
|
clojure.core-test.plus-squote 11 0
|
||||||
clojure.core-test.pos-int-qmark 1 0
|
clojure.core-test.pos-int-qmark 1 0
|
||||||
clojure.core-test.quot 25 0
|
clojure.core-test.quot 25 0
|
||||||
clojure.core-test.rand-nth 0 1
|
|
||||||
clojure.core-test.realized-qmark 1 0
|
clojure.core-test.realized-qmark 1 0
|
||||||
clojure.core-test.rem 16 0
|
clojure.core-test.rem 16 0
|
||||||
clojure.core-test.remove-watch 0 1
|
clojure.core-test.remove-watch 0 1
|
||||||
|
|
|
||||||
|
|
@ -576,4 +576,26 @@
|
||||||
{:suite "deftype-method" :expr "(do (defprotocol P (m [_ o])) (defrecord R [n] P (m [_ _] n)) (m (->R 5) :x))" :expected "5"}
|
{:suite "deftype-method" :expr "(do (defprotocol P (m [_ o])) (defrecord R [n] P (m [_ _] n)) (m (->R 5) :x))" :expected "5"}
|
||||||
{:suite "deftype-method" :expr "(do (defprotocol P2 (m2 [_ o])) (deftype T [n] P2 (m2 [_ _] n)) (m2 (->T 7) :x))" :expected "7"}
|
{:suite "deftype-method" :expr "(do (defprotocol P2 (m2 [_ o])) (deftype T [n] P2 (m2 [_ _] n)) (m2 (->T 7) :x))" :expected "7"}
|
||||||
{:suite "protocol-host" :expr "(do (defprotocol Q (e [_])) (extend-protocol Q clojure.lang.Var (e [_] :var)) [(satisfies? Q (var map)) (e (var map))])" :expected "[true :var]"}
|
{:suite "protocol-host" :expr "(do (defprotocol Q (e [_])) (extend-protocol Q clojure.lang.Var (e [_] :var)) [(satisfies? Q (var map)) (e (var map))])" :expected "[true :var]"}
|
||||||
|
|
||||||
|
;; Clojure 1.13 (1.13.0-alpha1) parity. Ahead of the JVM 1.12.5 the corpus
|
||||||
|
;; certifies against, so these live here rather than as certified corpus rows.
|
||||||
|
{:suite "clj-1.13 req!" :expr "(req! {:a 1} :a)" :expected "1"}
|
||||||
|
{:suite "clj-1.13 req!" :expr "(req! [10 20 30] 1)" :expected "20"}
|
||||||
|
{:suite "clj-1.13 req!" :expr "(nil? (req! {:a nil} :a))" :expected "true"}
|
||||||
|
{:suite "clj-1.13 req!" :expr "(req! {:a 1} :b)" :expected :throws}
|
||||||
|
{:suite "clj-1.13 amp-binding" :expr "(let [& 42] &)" :expected :throws}
|
||||||
|
{:suite "clj-1.13 amp-binding" :expr "(loop [& 42] &)" :expected :throws}
|
||||||
|
{:suite "clj-1.13 checked-keys" :expr "(let [{:keys! [a b]} {:a 1 :b 2}] [a b])" :expected "[1 2]"}
|
||||||
|
{:suite "clj-1.13 checked-keys" :expr "(let [{:keys! [a b]} {:a 1}] [a b])" :expected :throws}
|
||||||
|
{:suite "clj-1.13 checked-keys" :expr "(nil? (let [{:keys! [a]} {:a nil}] a))" :expected "true"}
|
||||||
|
{:suite "clj-1.13 checked-keys" :expr "(let [{:strs! [a]} {\"a\" 5}] a)" :expected "5"}
|
||||||
|
{:suite "clj-1.13 checked-keys" :expr "(let [{:keys! [a & b]} {:a 1 :b 2}] a)" :expected "1"}
|
||||||
|
{:suite "clj-1.13 checked-keys" :expr "(let [{:keys! [a & b]} {:a 1}] a)" :expected :throws}
|
||||||
|
{:suite "clj-1.13 checked-keys" :expr "(let [{:keys [a & b]} {:a 1 :b 2}] a)" :expected "1"}
|
||||||
|
{:suite "clj-1.13 checked-keys" :expr "(let [{:foo/keys! [a]} {:foo/a 7}] a)" :expected "7"}
|
||||||
|
{:suite "clj-1.13 checked-keys" :expr "(let [{:foo/keys! [a]} {}] a)" :expected :throws}
|
||||||
|
{:suite "clj-1.13 array-map-64" :expr "(keys {:a 1 :b 2 :c 3 :d 4 :e 5 :f 6 :g 7 :h 8 :i 9 :j 10})" :expected "(:a :b :c :d :e :f :g :h :i :j)"}
|
||||||
|
{:suite "clj-1.13 array-map-64" :expr "(= (map (fn [i] (keyword (str \"k\" i))) (range 20)) (keys (into {} (map (fn [i] [(keyword (str \"k\" i)) i]) (range 20)))))" :expected "true"}
|
||||||
|
{:suite "clj-1.13 array-map-64" :expr "(= (map (fn [i] (keyword (str \"k\" i))) (range 64)) (keys (reduce (fn [m i] (assoc m (keyword (str \"k\" i)) i)) {} (range 64))))" :expected "true"}
|
||||||
|
{:suite "clj-1.13 array-map-64" :expr "(= (map (fn [i] (keyword (str \"k\" i))) (range 65)) (keys (into {} (map (fn [i] [(keyword (str \"k\" i)) i]) (range 65)))))" :expected "false"}
|
||||||
]
|
]
|
||||||
|
|
|
||||||
|
|
@ -10,7 +10,7 @@ read one data file, run each case, compare, report.
|
||||||
|
|
||||||
| File | Role | Generated by |
|
| File | Role | Generated by |
|
||||||
|------|------|--------------|
|
|------|------|--------------|
|
||||||
| `test/chez/corpus.edn` | **The spec.** ~2900 cases of `{:suite :label :expected :actual}`, `:expected` **sourced from reference JVM Clojure**. | `test/conformance/regen-corpus.clj` |
|
| `test/chez/corpus.edn` | **The spec.** ~3570 cases of `{:suite :label :expected :actual :portability}`, `:expected` **sourced from reference JVM Clojure**. | `test/conformance/regen-corpus.clj` |
|
||||||
| `test/conformance/profile.edn` | Per-case **feature classification** — which non-portable cases need which host capability. | `certify.clj --profile` |
|
| `test/conformance/profile.edn` | Per-case **feature classification** — which non-portable cases need which host capability. | `certify.clj --profile` |
|
||||||
| `test/conformance/known-divergences.edn` | The few rows whose JVM value is an opaque host object that can't round-trip to readable source (Java arrays/transients/atoms/beans/proxies print as `#object[..@addr]`), so the corpus keeps jolt's value. | `regen-corpus.clj` leftovers, hand-checked |
|
| `test/conformance/known-divergences.edn` | The few rows whose JVM value is an opaque host object that can't round-trip to readable source (Java arrays/transients/atoms/beans/proxies print as `#object[..@addr]`), so the corpus keeps jolt's value. | `regen-corpus.clj` leftovers, hand-checked |
|
||||||
| `test/conformance/regen-corpus.clj` | Sources every `:expected` from reference **JVM Clojure** in one process. | — |
|
| `test/conformance/regen-corpus.clj` | Sources every `:expected` from reference **JVM Clojure** in one process. | — |
|
||||||
|
|
@ -54,8 +54,8 @@ the canonical, frozen contract**: it is what every runtime consumes, what
|
||||||
Historically every `:expected` was hand-written. `certify.clj` removes that
|
Historically every `:expected` was hand-written. `certify.clj` removes that
|
||||||
weakness: it evaluates every `:actual` (and `:expected`) on **JVM Clojure** in a
|
weakness: it evaluates every `:actual` (and `:expected`) on **JVM Clojure** in a
|
||||||
fresh `user` namespace and checks jolt's `:expected` against what real Clojure
|
fresh `user` namespace and checks jolt's `:expected` against what real Clojure
|
||||||
produces. Of ~2740 vanilla-certifiable rows, **>2730 match reference Clojure
|
produces. Of ~3400 vanilla-certifiable rows, **all but ~26 allowlisted rows
|
||||||
exactly**. The rest are classified (see below) — none are silently wrong.
|
match reference Clojure exactly**. The rest are classified (see below) — none are silently wrong.
|
||||||
|
|
||||||
```sh
|
```sh
|
||||||
clojure -M test/conformance/certify.clj # gate
|
clojure -M test/conformance/certify.clj # gate
|
||||||
|
|
@ -243,8 +243,7 @@ documented model divergence — nothing in the baseline is an unexplained bug:
|
||||||
- **vec of an array copies**: the reference ADOPTS an Object array (mutating
|
- **vec of an array copies**: the reference ADOPTS an Object array (mutating
|
||||||
the array mutates the vector); jolt copies — immutable semantics win over
|
the array mutates the vector); jolt copies — immutable semantics win over
|
||||||
the implementation leak (`vec` namespace, one row).
|
the implementation leak (`vec` namespace, one row).
|
||||||
- **eval of JVM shapes** (`rand-nth`/`eval` residue): rows needing JVM-only
|
|
||||||
evaluation shapes (e.g. evaluating a Java array literal).
|
|
||||||
|
|
||||||
A future change that makes any of these rows pass will fail the cts gate as
|
A future change that makes any of these rows pass will fail the cts gate as
|
||||||
STALE, forcing this section and the baseline to be updated together.
|
STALE, forcing this section and the baseline to be updated together.
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue