smalltalk: block intrinsifier (8 idioms) + 24 tests -> 847/847

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

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
 }

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

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)

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.