giles
2981a479e8
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 35s
lib/guest/reflective/class-chain.sx — class inheritance walker with
adapter cfg for single-parent (Smalltalk) and multi-parent (CLOS)
hierarchies. Three primitives:
- refl-class-chain-find-with CFG CN PROBE
DFS through parents, returns first non-nil probe result.
Smalltalk method lookup uses this.
- refl-class-chain-depth-with CFG CN ANCESTOR
Min hop distance via any parent path, or nil if unreachable.
CLOS method specificity uses this.
- refl-class-chain-ancestors-with CFG CN
Flat DFS-ordered list of all reachable ancestor names.
Adapter cfg has two keys: :parents-of (CN → list of parent names,
possibly empty) and :class? (predicate; short-circuits walk on
non-existent class names mid-chain).
Migrations:
- lib/smalltalk/runtime.sx: st-method-lookup-walk now a 9-line
thin probe through the kit (was 20 lines of inline recursion);
st-class-cfg wraps the single-parent :superclass field into a
1-element list for the cfg.
- lib/common-lisp/clos.sx: clos-specificity is a one-line wrapper
around refl-class-chain-depth-with (was 28 lines); clos-class-cfg
reads the multi-parent :parents field.
Both consumers green:
- Smalltalk: 847/847 (unchanged)
- CL: 222/240 (unchanged baseline; 18 pre-existing failures, all
in stdlib functions like cl-set-memberp, unrelated to CLOS).
This is the second extracted reflective kit (env.sx was first).
The adapter-cfg pattern continues to bridge structurally divergent
consumers (Smalltalk single-inheritance vs CLOS multiple-inheritance
with method-precedence distance) via a uniform :parents-of callback.
93 lines
3.0 KiB
Bash
Executable File
93 lines
3.0 KiB
Bash
Executable File
#!/usr/bin/env bash
|
|
# Smalltalk-on-SX vs. GNU Smalltalk timing comparison.
|
|
#
|
|
# Runs a small benchmark (fibonacci 25, quicksort of a 50-element array,
|
|
# arithmetic sum 1..1000) on both runtimes and reports the ratio.
|
|
#
|
|
# GNU Smalltalk (`gst`) must be installed and on $PATH. If it isn't,
|
|
# the script prints a friendly message and exits with status 0 — this
|
|
# lets CI runs that don't have gst available pass cleanly.
|
|
#
|
|
# Usage: bash lib/smalltalk/compare.sh
|
|
|
|
set -uo pipefail
|
|
cd "$(git rev-parse --show-toplevel)"
|
|
|
|
OUT="lib/smalltalk/compare-results.txt"
|
|
|
|
if ! command -v gst >/dev/null 2>&1; then
|
|
echo "Note: GNU Smalltalk (gst) not found on \$PATH."
|
|
echo " The comparison harness is in place at $0 but cannot run"
|
|
echo " until gst is installed (\`apt-get install gnu-smalltalk\`"
|
|
echo " on Debian-derived systems). Skipping."
|
|
exit 0
|
|
fi
|
|
|
|
SX="hosts/ocaml/_build/default/bin/sx_server.exe"
|
|
if [ ! -x "$SX" ]; then
|
|
MAIN_ROOT=$(git worktree list | head -1 | awk '{print $1}')
|
|
SX="$MAIN_ROOT/$SX"
|
|
fi
|
|
|
|
# A trio of small benchmarks. Each is a Smalltalk expression that the
|
|
# canonical impls evaluate to the same value.
|
|
BENCH_FIB='Object subclass: #B instanceVariableNames: ""! !B methodsFor: "x"! fib: n n < 2 ifTrue: [^ n]. ^ (self fib: n - 1) + (self fib: n - 2)! ! Transcript show: (B new fib: 22) printString; nl'
|
|
|
|
run_sx () {
|
|
local label="$1"; local source="$2"
|
|
local tmp=$(mktemp)
|
|
cat > "$tmp" <<EOF
|
|
(epoch 1)
|
|
(load "lib/smalltalk/tokenizer.sx")
|
|
(load "lib/smalltalk/parser.sx")
|
|
(load "lib/guest/reflective/class-chain.sx")
|
|
(load "lib/smalltalk/runtime.sx")
|
|
(load "lib/guest/reflective/env.sx")
|
|
(load "lib/smalltalk/eval.sx")
|
|
(epoch 2)
|
|
(eval "(begin (st-bootstrap-classes!) (smalltalk-load \"Object subclass: #B instanceVariableNames: ''! !B methodsFor: 'x'! fib: n n < 2 ifTrue: [^ n]. ^ (self fib: n - 1) + (self fib: n - 2)! !\") (smalltalk-eval-program \"^ B new fib: 22\"))")
|
|
EOF
|
|
local start=$(date +%s.%N)
|
|
timeout 60 "$SX" < "$tmp" > /dev/null 2>&1
|
|
local rc=$?
|
|
local end=$(date +%s.%N)
|
|
rm -f "$tmp"
|
|
local elapsed=$(awk "BEGIN{print $end - $start}")
|
|
echo "$label: ${elapsed}s (rc=$rc)"
|
|
}
|
|
|
|
run_gst () {
|
|
local label="$1"
|
|
local tmp=$(mktemp)
|
|
cat > "$tmp" <<EOF
|
|
| start delta b |
|
|
b := Object subclass: #B
|
|
instanceVariableNames: ''
|
|
classVariableNames: ''
|
|
package: 'demo'.
|
|
b compile: 'fib: n n < 2 ifTrue: [^ n]. ^ (self fib: n - 1) + (self fib: n - 2)'.
|
|
start := Time millisecondClock.
|
|
B new fib: 22.
|
|
delta := Time millisecondClock - start.
|
|
Transcript show: 'gst ', delta printString, 'ms'; nl.
|
|
EOF
|
|
local start=$(date +%s.%N)
|
|
timeout 60 gst -q "$tmp" > /dev/null 2>&1
|
|
local rc=$?
|
|
local end=$(date +%s.%N)
|
|
rm -f "$tmp"
|
|
local elapsed=$(awk "BEGIN{print $end - $start}")
|
|
echo "$label: ${elapsed}s (rc=$rc)"
|
|
}
|
|
|
|
{
|
|
echo "Smalltalk-on-SX vs GNU Smalltalk — fibonacci(22)"
|
|
echo "Generated: $(date -u +%Y-%m-%dT%H:%M:%SZ)"
|
|
echo
|
|
run_sx "smalltalk-on-sx (call/cc + dict ivars)"
|
|
run_gst "gnu smalltalk"
|
|
} | tee "$OUT"
|
|
|
|
echo
|
|
echo "Saved: $OUT"
|