From 8b7b6ad028d2a709feb570bd1cb79377a5e41c7c Mon Sep 17 00:00:00 2001 From: giles Date: Sat, 25 Apr 2026 02:23:47 +0000 Subject: [PATCH] smalltalk: method-lookup cache + 10 tests --- lib/smalltalk/runtime.sx | 106 +++++++++++++++++++++++++++++++-- lib/smalltalk/tests/runtime.sx | 73 +++++++++++++++++++++++ plans/smalltalk-on-sx.md | 3 +- 3 files changed, 176 insertions(+), 6 deletions(-) diff --git a/lib/smalltalk/runtime.sx b/lib/smalltalk/runtime.sx index 1f66e5ec..9693be25 100644 --- a/lib/smalltalk/runtime.sx +++ b/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 diff --git a/lib/smalltalk/tests/runtime.sx b/lib/smalltalk/tests/runtime.sx index 3561132e..8398c64c 100644 --- a/lib/smalltalk/tests/runtime.sx +++ b/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) diff --git a/plans/smalltalk-on-sx.md b/plans/smalltalk-on-sx.md index a6fc1b60..e732d93f 100644 --- a/plans/smalltalk-on-sx.md +++ b/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.