smalltalk: method-lookup cache + 10 tests

lib/smalltalk/runtime.sx

@@ -17,7 +17,43 @@
 
 (define st-class-table {})
 
-(define st-class-table-clear! (fn () (set! st-class-table {})))
+;; ── Method-lookup cache ────────────────────────────────────────────────
+;; Cache keys are "class|selector|side"; side is "i" (instance) or "c" (class).
+;; Misses are stored as the sentinel :not-found so we don't re-walk for
+;; every doesNotUnderstand call.
+(define st-method-cache {})
+(define st-method-cache-hits 0)
+(define st-method-cache-misses 0)
+
+(define
+  st-method-cache-clear!
+  (fn () (set! st-method-cache {})))
+
+(define
+  st-method-cache-key
+  (fn (cls sel class-side?) (str cls "|" sel "|" (if class-side? "c" "i"))))
+
+(define
+  st-method-cache-stats
+  (fn
+    ()
+    {:hits st-method-cache-hits
+     :misses st-method-cache-misses
+     :size (len (keys st-method-cache))}))
+
+(define
+  st-method-cache-reset-stats!
+  (fn ()
+    (begin
+      (set! st-method-cache-hits 0)
+      (set! st-method-cache-misses 0))))
+
+(define
+  st-class-table-clear!
+  (fn ()
+    (begin
+      (set! st-class-table {})
+      (st-method-cache-clear!))))
 
 (define
   st-class-define!
@@ -34,6 +70,9 @@
            :ivars ivars
            :methods {}
            :class-methods {}}))
+      ;; A redefined class can invalidate any cache entries that walked
+      ;; through its old position in the chain. Cheap + correct: drop all.
+      (st-method-cache-clear!)
       name)))
 
 (define
@@ -114,6 +153,7 @@
                     cls
                     :methods
                     (assoc (get cls :methods) selector m))))
+              (st-method-cache-clear!)
               selector)))))))
 
 (define
@@ -137,13 +177,43 @@
                     cls
                     :class-methods
                     (assoc (get cls :class-methods) selector m))))
+              (st-method-cache-clear!)
               selector)))))))
 
-;; Method lookup: walk superclass chain starting at `cls-name`.
-;; class-side? = true searches :class-methods, false searches :methods.
-;; Returns the method record (with :defining-class) or nil.
+;; Remove a method from a class (instance side). Mostly for tests; runtime
+;; reflection in Phase 4 will use the same primitive.
 (define
-  st-method-lookup
+  st-class-remove-method!
+  (fn
+    (cls-name selector)
+    (let ((cls (st-class-get cls-name)))
+      (cond
+        ((= cls nil) (error (str "st-class-remove-method!: unknown class " cls-name)))
+        (else
+          (let ((md (get cls :methods)))
+            (cond
+              ((not (has-key? md selector)) false)
+              (else
+                (let ((new-md {}))
+                  (begin
+                    (for-each
+                      (fn (k)
+                        (when (not (= k selector))
+                          (dict-set! new-md k (get md k))))
+                      (keys md))
+                    (set!
+                      st-class-table
+                      (assoc
+                        st-class-table
+                        cls-name
+                        (assoc cls :methods new-md)))
+                    (st-method-cache-clear!)
+                    true))))))))))
+
+;; Walk-only lookup. Returns the method record (with :defining-class) or nil.
+;; class-side? = true searches :class-methods, false searches :methods.
+(define
+  st-method-lookup-walk
   (fn
     (cls-name selector class-side?)
     (let
@@ -165,6 +235,32 @@
         (ml-loop cls-name)
         found))))
 
+;; Cached lookup. Misses are stored as :not-found so doesNotUnderstand paths
+;; don't re-walk on every send.
+(define
+  st-method-lookup
+  (fn
+    (cls-name selector class-side?)
+    (let ((key (st-method-cache-key cls-name selector class-side?)))
+      (cond
+        ((has-key? st-method-cache key)
+          (begin
+            (set! st-method-cache-hits (+ st-method-cache-hits 1))
+            (let ((v (get st-method-cache key)))
+              (cond ((= v :not-found) nil) (else v)))))
+        (else
+          (begin
+            (set! st-method-cache-misses (+ st-method-cache-misses 1))
+            (let ((found (st-method-lookup-walk cls-name selector class-side?)))
+              (begin
+                (set!
+                  st-method-cache
+                  (assoc
+                    st-method-cache
+                    key
+                    (cond ((= found nil) :not-found) (else found))))
+                found))))))))
+
 ;; SX value → Smalltalk class name. Native types are not boxed.
 (define
   st-class-of

lib/smalltalk/tests/runtime.sx

@@ -179,4 +179,77 @@
 (st-test "after re-bootstrap Account gone" (st-class-exists? "Account") false)
 (st-test "after re-bootstrap Object stays" (st-class-exists? "Object") true)
 
+;; ── 10. Method-lookup cache ──
+(st-bootstrap-classes!)
+(st-class-define! "Foo" "Object" (list))
+(st-class-define! "Bar" "Foo" (list))
+(st-class-add-method! "Foo" "greet" (st-parse-method "greet ^ 1"))
+
+;; Bootstrap clears cache; record stats from now.
+(st-method-cache-reset-stats!)
+
+;; First lookup is a miss; second is a hit.
+(st-method-lookup "Bar" "greet" false)
+(st-test
+  "first lookup recorded as miss"
+  (get (st-method-cache-stats) :misses)
+  1)
+(st-test
+  "first lookup recorded as hit count zero"
+  (get (st-method-cache-stats) :hits)
+  0)
+
+(st-method-lookup "Bar" "greet" false)
+(st-test
+  "second lookup hits cache"
+  (get (st-method-cache-stats) :hits)
+  1)
+
+;; Misses are also cached as :not-found.
+(st-method-lookup "Bar" "frobnicate" false)
+(st-method-lookup "Bar" "frobnicate" false)
+(st-test
+  "negative-result caches"
+  (get (st-method-cache-stats) :hits)
+  2)
+
+;; Adding a new method invalidates the cache.
+(st-class-add-method! "Bar" "greet" (st-parse-method "greet ^ 2"))
+(st-test
+  "cache cleared on method add"
+  (get (st-method-cache-stats) :size)
+  0)
+(st-test
+  "after invalidation lookup picks up override"
+  (get (st-method-lookup "Bar" "greet" false) :defining-class)
+  "Bar")
+
+;; Removing a method also invalidates and exposes the inherited one.
+(st-class-remove-method! "Bar" "greet")
+(st-test
+  "after remove lookup falls through to Foo"
+  (get (st-method-lookup "Bar" "greet" false) :defining-class)
+  "Foo")
+
+;; Cache survives across unrelated class-table mutations? No — define! clears.
+(st-method-lookup "Foo" "greet" false)  ; warm cache
+(st-class-define! "Baz" "Object" (list))
+(st-test
+  "class-define clears cache"
+  (get (st-method-cache-stats) :size)
+  0)
+
+;; Class-side and instance-side cache entries are separate keys.
+(st-class-add-class-method! "Foo" "make" (st-parse-method "make ^ self new"))
+(st-method-lookup "Foo" "make" true)
+(st-method-lookup "Foo" "make" false)
+(st-test
+  "class-side hit found, instance-side stored as not-found"
+  (= (st-method-lookup "Foo" "make" true) nil)
+  false)
+(st-test
+  "instance-side same selector returns nil"
+  (st-method-lookup "Foo" "make" false)
+  nil)
+
 (list st-test-pass st-test-fail)

plans/smalltalk-on-sx.md

@@ -58,7 +58,7 @@ Core mapping:
 ### Phase 2 — object model + sequential eval
 - [x] Class table + bootstrap (`lib/smalltalk/runtime.sx`): canonical hierarchy installed (`Object`, `Behavior`, `ClassDescription`, `Class`, `Metaclass`, `UndefinedObject`, `Boolean`/`True`/`False`, `Magnitude`/`Number`/`Integer`/`SmallInteger`/`Float`/`Character`, `Collection`/`SequenceableCollection`/`ArrayedCollection`/`Array`/`String`/`Symbol`/`OrderedCollection`/`Dictionary`, `BlockClosure`). User class definition via `st-class-define!`, methods via `st-class-add-method!` (stamps `:defining-class` for super), method lookup walks chain, ivars accumulated through superclass chain, native SX value types map to Smalltalk classes via `st-class-of`.
 - [x] `smalltalk-eval-ast` (`lib/smalltalk/eval.sx`): all literal kinds, ident resolution (locals → ivars → class refs), self/super/thisContext, assignment (locals or ivars, mutating), message send, cascade, sequence, and ^return via a sentinel marker (proper continuation-based escape is the Phase 3 showcase). Frames carry a parent chain so blocks close over outer locals. Primitive method tables for SmallInteger/Float, String/Symbol, Boolean, UndefinedObject, Array, BlockClosure (value/value:/whileTrue:/etc.), and class-side `new`/`name`/etc. Also satisfies "30+ tests" — 60 eval tests.
-- [ ] Method lookup: walk class → superclass; cache hit-class on `(class, selector)`
+- [x] Method lookup: walk class → superclass already in `st-method-lookup-walk`; new cached wrapper `st-method-lookup` keys on `(class, selector, side)` and stores `:not-found` for negative results so DNU paths don't re-walk. Cache invalidates on `st-class-define!`, `st-class-add-method!`, `st-class-add-class-method!`, `st-class-remove-method!`, and full bootstrap. Stats helpers `st-method-cache-stats` / `st-method-cache-reset-stats!` for tests + later debugging.
 - [ ] `doesNotUnderstand:` fallback constructing `Message` object
 - [ ] `super` send (lookup starts at superclass of *defining* class, not receiver class)
 - [x] 30+ tests in `lib/smalltalk/tests/eval.sx` (60 tests, covering literals through user-class method dispatch with cascades and closures)
@@ -108,6 +108,7 @@ Core mapping:
 
 _Newest first. Agent appends on every commit._
 
+- 2026-04-25: method-lookup cache (`st-method-cache` keyed by `class|selector|side`, stores `:not-found` for misses). Invalidation on define/add/remove + bootstrap. `st-class-remove-method!` added. Stats helpers + 10 cache tests; 255/255 total.
 - 2026-04-25: `smalltalk-eval-ast` + 60 eval tests (`lib/smalltalk/eval.sx`, `lib/smalltalk/tests/eval.sx`). Frame chain with mutable locals/ivars (via `dict-set!`), full literal eval, send dispatch (user methods + native primitive tables for Number/String/Boolean/Nil/Array/Block/Class), block closures, while/to:do:, cascades returning last, sentinel-based `^return`. User Point class round-trip works including `+` returning a fresh point. 245/245 total.
 - 2026-04-25: class table + bootstrap (`lib/smalltalk/runtime.sx`, `lib/smalltalk/tests/runtime.sx`). Canonical hierarchy, type→class mapping for native SX values, instance construction, ivar inheritance, method install with `:defining-class` stamp, instance- and class-side method lookup walking the superclass chain. 54 new tests, 185/185 total.
 - 2026-04-25: chunk-stream parser + pragmas + 21 chunk/pragma tests (`lib/smalltalk/tests/parse_chunks.sx`). `st-read-chunks` (with `!!` doubling), `st-parse-chunks` state machine for `methodsFor:` batches incl. class-side. Pragmas with multiple keyword pairs, signed numeric / string / symbol args, in either pragma-then-temps or temps-then-pragma order. 131/131 tests pass.