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