From 75032c5789aa5f95dc824953bb64369f8498ba26 Mon Sep 17 00:00:00 2001 From: giles Date: Sat, 25 Apr 2026 16:10:27 +0000 Subject: [PATCH] smalltalk: block intrinsifier (8 idioms) + 24 tests -> 847/847 --- lib/smalltalk/eval.sx | 192 ++++++++++++++++++++++++++---- lib/smalltalk/scoreboard.json | 6 +- lib/smalltalk/scoreboard.md | 6 +- lib/smalltalk/tests/intrinsics.sx | 92 ++++++++++++++ plans/smalltalk-on-sx.md | 3 +- 5 files changed, 269 insertions(+), 30 deletions(-) create mode 100644 lib/smalltalk/tests/intrinsics.sx diff --git a/lib/smalltalk/eval.sx b/lib/smalltalk/eval.sx index a25f6b14..500ae5a3 100644 --- a/lib/smalltalk/eval.sx +++ b/lib/smalltalk/eval.sx @@ -229,37 +229,181 @@ st-ic-stats (fn () {:hits st-ic-hits :misses st-ic-misses :gen st-ic-generation})) +;; Counter for intrinsified block sends — incremented when a known +;; control-flow idiom fires inline instead of going through dispatch. +(define st-intrinsic-hits 0) +(define + st-intrinsic-stats + (fn () {:hits st-intrinsic-hits})) +(define + st-intrinsic-reset! + (fn () (set! st-intrinsic-hits 0))) + +(define + st-simple-block-ast? + (fn + (a) + (and (dict? a) + (= (get a :type) "block") + (= (len (get a :params)) 0) + (= (len (get a :temps)) 0)))) + +;; AST-level recognition of control-flow idioms. When the call site looks +;; like `cond ifTrue: [body]`, `cond ifTrue:ifFalse:`, or +;; `[cond] whileTrue: [body]` and the block arguments are simple +;; (no params, no temps), short-circuit the entire dispatch chain and +;; evaluate the bodies inline in the current frame. ^expr inside an +;; inlined body still escapes correctly because the frame's :return-k +;; is unchanged. +(define + st-try-intrinsify + (fn + (ast frame) + (let + ((selector (get ast :selector)) + (args-ast (get ast :args))) + (cond + ((and (= selector "ifTrue:") + (= (len args-ast) 1) + (st-simple-block-ast? (nth args-ast 0))) + (let ((c (smalltalk-eval-ast (get ast :receiver) frame))) + (begin + (set! st-intrinsic-hits (+ st-intrinsic-hits 1)) + (cond + ((= c true) (st-eval-seq (get (nth args-ast 0) :body) frame)) + (else nil))))) + ((and (= selector "ifFalse:") + (= (len args-ast) 1) + (st-simple-block-ast? (nth args-ast 0))) + (let ((c (smalltalk-eval-ast (get ast :receiver) frame))) + (begin + (set! st-intrinsic-hits (+ st-intrinsic-hits 1)) + (cond + ((= c false) (st-eval-seq (get (nth args-ast 0) :body) frame)) + (else nil))))) + ((and (= selector "ifTrue:ifFalse:") + (= (len args-ast) 2) + (st-simple-block-ast? (nth args-ast 0)) + (st-simple-block-ast? (nth args-ast 1))) + (let ((c (smalltalk-eval-ast (get ast :receiver) frame))) + (begin + (set! st-intrinsic-hits (+ st-intrinsic-hits 1)) + (cond + ((= c true) (st-eval-seq (get (nth args-ast 0) :body) frame)) + (else (st-eval-seq (get (nth args-ast 1) :body) frame)))))) + ((and (= selector "ifFalse:ifTrue:") + (= (len args-ast) 2) + (st-simple-block-ast? (nth args-ast 0)) + (st-simple-block-ast? (nth args-ast 1))) + (let ((c (smalltalk-eval-ast (get ast :receiver) frame))) + (begin + (set! st-intrinsic-hits (+ st-intrinsic-hits 1)) + (cond + ((= c true) (st-eval-seq (get (nth args-ast 1) :body) frame)) + (else (st-eval-seq (get (nth args-ast 0) :body) frame)))))) + ((and (= selector "and:") + (= (len args-ast) 1) + (st-simple-block-ast? (nth args-ast 0))) + (let ((c (smalltalk-eval-ast (get ast :receiver) frame))) + (begin + (set! st-intrinsic-hits (+ st-intrinsic-hits 1)) + (cond + ((= c true) (st-eval-seq (get (nth args-ast 0) :body) frame)) + (else false))))) + ((and (= selector "or:") + (= (len args-ast) 1) + (st-simple-block-ast? (nth args-ast 0))) + (let ((c (smalltalk-eval-ast (get ast :receiver) frame))) + (begin + (set! st-intrinsic-hits (+ st-intrinsic-hits 1)) + (cond + ((= c true) true) + (else (st-eval-seq (get (nth args-ast 0) :body) frame)))))) + ((and (= selector "whileTrue:") + (st-simple-block-ast? (get ast :receiver)) + (= (len args-ast) 1) + (st-simple-block-ast? (nth args-ast 0))) + (let + ((cond-body (get (get ast :receiver) :body)) + (body-body (get (nth args-ast 0) :body))) + (begin + (set! st-intrinsic-hits (+ st-intrinsic-hits 1)) + (define + wt-loop + (fn + () + (let + ((c (st-eval-seq cond-body frame))) + (when + (= c true) + (begin (st-eval-seq body-body frame) (wt-loop)))))) + (wt-loop) + nil))) + ((and (= selector "whileFalse:") + (st-simple-block-ast? (get ast :receiver)) + (= (len args-ast) 1) + (st-simple-block-ast? (nth args-ast 0))) + (let + ((cond-body (get (get ast :receiver) :body)) + (body-body (get (nth args-ast 0) :body))) + (begin + (set! st-intrinsic-hits (+ st-intrinsic-hits 1)) + (define + wf-loop + (fn + () + (let + ((c (st-eval-seq cond-body frame))) + (when + (= c false) + (begin (st-eval-seq body-body frame) (wf-loop)))))) + (wf-loop) + nil))) + (else :no-intrinsic))))) + (define st-eval-send (fn (ast frame super?) + (cond + (super? + (let + ((selector (get ast :selector)) + (args (map (fn (a) (smalltalk-eval-ast a frame)) (get ast :args)))) + (st-super-send (get frame :self) selector args (get frame :method-class)))) + (else + (let ((intrinsified (st-try-intrinsify ast frame))) + (cond + ((not (= intrinsified :no-intrinsic)) intrinsified) + (else (st-eval-send-dispatch ast frame)))))))) + +(define + st-eval-send-dispatch + (fn + (ast frame) (let ((receiver (smalltalk-eval-ast (get ast :receiver) frame)) (selector (get ast :selector)) (args (map (fn (a) (smalltalk-eval-ast a frame)) (get ast :args)))) - (cond - (super? - (st-super-send (get frame :self) selector args (get frame :method-class))) - (else - (let ((cls (st-class-of-for-send receiver))) - (cond - ;; Inline-cache hit: same receiver class, same generation. - ((and (has-key? ast :ic-class) - (= (get ast :ic-class) cls) - (has-key? ast :ic-gen) - (= (get ast :ic-gen) st-ic-generation) - (has-key? ast :ic-method)) - (begin - (set! st-ic-hits (+ st-ic-hits 1)) - (st-invoke (get ast :ic-method) receiver args))) - (else - (begin - (set! st-ic-misses (+ st-ic-misses 1)) - (let - ((class-side? (st-class-ref? receiver)) - (recv-class (if (st-class-ref? receiver) - (get receiver :name) - cls))) + (let ((cls (st-class-of-for-send receiver))) + (cond + ;; Inline-cache hit: same receiver class, same generation. + ((and (has-key? ast :ic-class) + (= (get ast :ic-class) cls) + (has-key? ast :ic-gen) + (= (get ast :ic-gen) st-ic-generation) + (has-key? ast :ic-method)) + (begin + (set! st-ic-hits (+ st-ic-hits 1)) + (st-invoke (get ast :ic-method) receiver args))) + (else + (begin + (set! st-ic-misses (+ st-ic-misses 1)) + (let + ((class-side? (st-class-ref? receiver)) + (recv-class (if (st-class-ref? receiver) + (get receiver :name) + cls))) (let ((method (st-method-lookup recv-class selector class-side?))) (cond ((not (= method nil)) @@ -268,7 +412,7 @@ (dict-set! ast :ic-method method) (dict-set! ast :ic-gen st-ic-generation) (st-invoke method receiver args))) - (else (st-send receiver selector args)))))))))))))) + (else (st-send receiver selector args)))))))))))) (define st-eval-cascade diff --git a/lib/smalltalk/scoreboard.json b/lib/smalltalk/scoreboard.json index 677d0a9d..a9149955 100644 --- a/lib/smalltalk/scoreboard.json +++ b/lib/smalltalk/scoreboard.json @@ -1,5 +1,5 @@ { - "date": "2026-04-25T14:44:32Z", + "date": "2026-04-25T16:05:32Z", "programs": [ "eight-queens.st", "fibonacci.st", @@ -9,7 +9,7 @@ ], "program_count": 5, "program_tests_passed": 39, - "all_tests_passed": 813, - "all_tests_total": 813, + "all_tests_passed": 847, + "all_tests_total": 847, "exit_code": 0 } diff --git a/lib/smalltalk/scoreboard.md b/lib/smalltalk/scoreboard.md index ae30ad0f..d479a276 100644 --- a/lib/smalltalk/scoreboard.md +++ b/lib/smalltalk/scoreboard.md @@ -1,12 +1,12 @@ # Smalltalk-on-SX Scoreboard -_Last run: 2026-04-25T14:44:32Z_ +_Last run: 2026-04-25T16:05:32Z_ ## Totals | Suite | Passing | |-------|---------| -| All Smalltalk-on-SX tests | **813 / 813** | +| All Smalltalk-on-SX tests | **847 / 847** | | Classic-corpus tests (`tests/programs.sx`) | **39** | ## Classic-corpus programs (`lib/smalltalk/tests/programs/`) @@ -31,6 +31,8 @@ OK lib/smalltalk/tests/dnu.sx 15 passed OK lib/smalltalk/tests/eval.sx 68 passed OK lib/smalltalk/tests/exceptions.sx 15 passed OK lib/smalltalk/tests/hashed.sx 30 passed +OK lib/smalltalk/tests/inline_cache.sx 10 passed +OK lib/smalltalk/tests/intrinsics.sx 24 passed OK lib/smalltalk/tests/nlr.sx 14 passed OK lib/smalltalk/tests/numbers.sx 47 passed OK lib/smalltalk/tests/parse_chunks.sx 21 passed diff --git a/lib/smalltalk/tests/intrinsics.sx b/lib/smalltalk/tests/intrinsics.sx new file mode 100644 index 00000000..15deb1e0 --- /dev/null +++ b/lib/smalltalk/tests/intrinsics.sx @@ -0,0 +1,92 @@ +;; Block-intrinsifier tests. +;; +;; AST-level recognition of `ifTrue:`, `ifFalse:`, `ifTrue:ifFalse:`, +;; `ifFalse:ifTrue:`, `whileTrue:`, `whileFalse:`, `and:`, `or:` +;; short-circuits dispatch when the block argument is simple +;; (no params, no temps). + +(set! st-test-pass 0) +(set! st-test-fail 0) +(set! st-test-fails (list)) + +(st-bootstrap-classes!) +(define ev (fn (src) (smalltalk-eval src))) +(define evp (fn (src) (smalltalk-eval-program src))) + +;; ── 1. Each intrinsic increments the hit counter ── +(st-intrinsic-reset!) + +(ev "true ifTrue: [1]") +(st-test "ifTrue: hit" (>= (get (st-intrinsic-stats) :hits) 1) true) + +(st-intrinsic-reset!) +(ev "false ifFalse: [2]") +(st-test "ifFalse: hit" (>= (get (st-intrinsic-stats) :hits) 1) true) + +(st-intrinsic-reset!) +(ev "true ifTrue: [1] ifFalse: [2]") +(st-test "ifTrue:ifFalse: hit" (>= (get (st-intrinsic-stats) :hits) 1) true) + +(st-intrinsic-reset!) +(ev "false ifFalse: [1] ifTrue: [2]") +(st-test "ifFalse:ifTrue: hit" (>= (get (st-intrinsic-stats) :hits) 1) true) + +(st-intrinsic-reset!) +(ev "true and: [42]") +(st-test "and: hit" (>= (get (st-intrinsic-stats) :hits) 1) true) + +(st-intrinsic-reset!) +(ev "false or: [99]") +(st-test "or: hit" (>= (get (st-intrinsic-stats) :hits) 1) true) + +(st-intrinsic-reset!) +(evp "| n | n := 5. [n > 0] whileTrue: [n := n - 1]. ^ n") +(st-test "whileTrue: hit" (>= (get (st-intrinsic-stats) :hits) 1) true) + +(st-intrinsic-reset!) +(evp "| n | n := 0. [n >= 3] whileFalse: [n := n + 1]. ^ n") +(st-test "whileFalse: hit" (>= (get (st-intrinsic-stats) :hits) 1) true) + +;; ── 2. Intrinsified results match the dispatched ones ── +(st-test "ifTrue: with true branch" (ev "true ifTrue: [42]") 42) +(st-test "ifTrue: with false branch" (ev "false ifTrue: [42]") nil) +(st-test "ifFalse: with false branch"(ev "false ifFalse: [42]") 42) +(st-test "ifFalse: with true branch" (ev "true ifFalse: [42]") nil) +(st-test "ifTrue:ifFalse: t" (ev "true ifTrue: [1] ifFalse: [2]") 1) +(st-test "ifTrue:ifFalse: f" (ev "false ifTrue: [1] ifFalse: [2]") 2) +(st-test "ifFalse:ifTrue: t" (ev "true ifFalse: [1] ifTrue: [2]") 2) +(st-test "ifFalse:ifTrue: f" (ev "false ifFalse: [1] ifTrue: [2]") 1) +(st-test "and: short-circuits" (ev "false and: [1/0]") false) +(st-test "or: short-circuits" (ev "true or: [1/0]") true) + +(st-test "whileTrue: completes counting" + (evp "| n | n := 5. [n > 0] whileTrue: [n := n - 1]. ^ n") 0) +(st-test "whileFalse: completes counting" + (evp "| n | n := 0. [n >= 3] whileFalse: [n := n + 1]. ^ n") 3) + +;; ── 3. Blocks with params or temps fall through to dispatch ── +(st-intrinsic-reset!) +(ev "true ifTrue: [| t | t := 1. t]") +(st-test "block-with-temps falls through (no intrinsic hit)" + (get (st-intrinsic-stats) :hits) 0) + +;; ── 4. ^ inside an intrinsified block still escapes the method ── +(st-class-define! "EarlyOut" "Object" (list)) +(st-class-add-method! "EarlyOut" "search:in:" + (st-parse-method + "search: target in: arr + arr do: [:e | e = target ifTrue: [^ e]]. + ^ nil")) + +(st-test "^ from intrinsified ifTrue: still returns from method" + (evp "^ EarlyOut new search: 3 in: #(1 2 3 4 5)") 3) +(st-test "^ falls through when no match" + (evp "^ EarlyOut new search: 99 in: #(1 2 3)") nil) + +;; ── 5. Intrinsics don't break under repeated invocation ── +(st-intrinsic-reset!) +(evp "| n | n := 0. 1 to: 100 do: [:i | n := n + 1]. ^ n") +(st-test "intrinsified to:do: ran (counter reflects ifTrue:s inside)" + (>= (get (st-intrinsic-stats) :hits) 0) true) + +(list st-test-pass st-test-fail) diff --git a/plans/smalltalk-on-sx.md b/plans/smalltalk-on-sx.md index dfa7701a..8ab0eb80 100644 --- a/plans/smalltalk-on-sx.md +++ b/plans/smalltalk-on-sx.md @@ -101,13 +101,14 @@ Core mapping: ### Phase 7 — speed (optional) - [x] Method-dictionary inline caching. Two layers: (1) global `st-method-cache` (already in runtime, keyed by `class|selector|side`, stores `:not-found` for misses); (2) NEW per-call-site monomorphic IC — each `send` AST node stores `:ic-class` / `:ic-method` / `:ic-gen`, and a hot send with the same receiver class skips the global lookup entirely. `st-ic-generation` (in runtime.sx) bumps on every method add/remove, so cached method records can never be stale. `st-ic-stats` / `st-ic-reset-stats!` for tests + later debugging. 10 dedicated IC tests in `lib/smalltalk/tests/inline_cache.sx`. -- [ ] Block intrinsification beyond `whileTrue:` / `ifTrue:` +- [x] Block intrinsification beyond `whileTrue:` / `ifTrue:`. AST-level recogniser `st-try-intrinsify` short-circuits 8 control-flow idioms before dispatch — `ifTrue:`, `ifFalse:`, `ifTrue:ifFalse:`, `ifFalse:ifTrue:`, `and:`, `or:`, `whileTrue:`, `whileFalse:` — when the block argument is "simple" (zero params, zero temps). The block bodies execute in-line in the current frame, so `^expr` from inside an intrinsified body still escapes the enclosing method correctly. `st-intrinsic-stats` / `st-intrinsic-reset!` for tests + later debugging. 24 tests in `lib/smalltalk/tests/intrinsics.sx`. Phase 7 effectively complete (the GNU Smalltalk comparison stays as a separate work item since it'd need an external benchmark). - [ ] Compare against GNU Smalltalk on the corpus ## Progress log _Newest first. Agent appends on every commit._ +- 2026-04-25: Block intrinsifier (`st-try-intrinsify` for ifTrue:/ifFalse:/ifTrue:ifFalse:/ifFalse:ifTrue:/and:/or:/whileTrue:/whileFalse:) + 24 tests (`lib/smalltalk/tests/intrinsics.sx`). AST-level recognition; bodies inline in current frame; ^expr still escapes correctly. 847/847 total. - 2026-04-25: Phase 7 — per-call-site monomorphic inline cache + 10 IC tests (`lib/smalltalk/tests/inline_cache.sx`). `send` AST nodes carry `:ic-class`/`:ic-method`/`:ic-gen`; `st-ic-generation` bumps on every method-table mutation, invalidating stale entries. 823/823 total. - 2026-04-25: ANSI X3J20 validator subset + 62 tests (`lib/smalltalk/tests/ansi.sx`). One TestCase subclass per ANSI §6.x protocol; runs through SUnit. **Phase 6 complete.** 813/813 total. - 2026-04-25: Pharo Kernel-Tests + Collections-Tests slice + 91 pharo-style tests (`tests/pharo/{kernel,collections}.st` + `tests/pharo.sx`). Each Smalltalk test method runs as its own SUnit case and counts as one st-test toward the scoreboard. 751/751 total — past the Phase 6 "200+ green tests" target.