master: Reduce recursion in sb-walker
stassats via Sbcl-commits <[email protected]> Fri, 15 May 2026 21:37:28 +0000
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via 1f8a40c435fc3df7a41500db298c84000e3adce8 (commit)
from f39348923980ca6ca006bef3e5cca23a5bb04978 (commit)
- Log -----------------------------------------------------------------
commit 1f8a40c435fc3df7a41500db298c84000e3adce8
Author: Stas Boukarev <[email protected]>
Date: Fri May 15 23:56:49 2026 +0300
Reduce recursion in sb-walker
For linear bodies.
---
src/compiler/node.lisp | 14 +++++++
src/pcl/walk.lisp | 103 +++++++++++++++++++++----------------------------
tests/clos.impure.lisp | 6 +++
3 files changed, 65 insertions(+), 58 deletions(-)
diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp
index 025659303..8ae84b755 100644
--- a/src/compiler/node.lisp
+++ b/src/compiler/node.lisp
@@ -98,6 +98,20 @@
;; flushed in some circumstances.
(flushable nil :type list))
+#+sb-devel
+(defprinter (lexenv)
+ vars
+ blocks
+ tags
+ (type-restrictions :test type-restrictions)
+ (lambda :test lambda)
+ (cleanup :test cleanup)
+ (handled-conditions :test handled-conditions)
+ (disabled-package-locks :test disabled-package-locks)
+ (%policy :test %policy)
+ (user-data :test user-data)
+ (flushable :test flushable))
+
#+sb-eval
(defstruct (sb-eval::eval-lexenv
(:include lexenv)
diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp
index ad7218ea7..a2d7e65a6 100644
--- a/src/pcl/walk.lisp
+++ b/src/pcl/walk.lisp
@@ -396,14 +396,14 @@
;;; walker.
(defmacro define-walker-template (name
- &optional (template '(nil repeat (eval))))
+ &optional (template '(nil repeat eval)))
`(setf (info :function :walker-template ',name) ',template))
(defun get-walker-template (x context)
(cond ((symbolp x)
(info :function :walker-template x))
((and (listp x) (eq (car x) 'lambda))
- '(lambda repeat (eval)))
+ '(lambda repeat eval))
(t
;; FIXME: In an ideal world we would do something similar to
;; COMPILER-ERROR here, replacing the form within the walker
@@ -416,10 +416,10 @@
;;;; the actual templates
;;; ANSI special forms
-(define-walker-template block (nil nil repeat (eval)))
-(define-walker-template catch (nil eval repeat (eval)))
+(define-walker-template block (nil nil repeat eval))
+(define-walker-template catch (nil eval repeat eval))
(define-walker-template declare walk-unexpected-declare)
-(define-walker-template eval-when (nil quote repeat (eval)))
+(define-walker-template eval-when (nil quote repeat eval))
(define-walker-template flet walk-flet)
(define-walker-template function (nil call))
(define-walker-template go (nil quote))
@@ -431,18 +431,18 @@
(define-walker-template load-time-value walk-load-time-value)
(define-walker-template locally walk-locally)
(define-walker-template macrolet walk-macrolet)
-(define-walker-template multiple-value-call (nil eval repeat (eval)))
-(define-walker-template multiple-value-prog1 (nil return repeat (eval)))
-(define-walker-template progn (nil repeat (eval)))
-(define-walker-template progv (nil eval eval repeat (eval)))
+(define-walker-template multiple-value-call (nil eval repeat eval))
+(define-walker-template multiple-value-prog1 (nil return repeat eval))
+(define-walker-template progn (nil repeat eval))
+(define-walker-template progv (nil eval eval repeat eval))
(define-walker-template quote (nil quote))
-(define-walker-template return-from (nil quote repeat (return)))
+(define-walker-template return-from (nil quote repeat return))
(define-walker-template setq walk-setq)
(define-walker-template symbol-macrolet walk-symbol-macrolet)
(define-walker-template tagbody walk-tagbody)
(define-walker-template the (nil quote eval))
(define-walker-template throw (nil eval eval))
-(define-walker-template unwind-protect (nil return repeat (eval)))
+(define-walker-template unwind-protect (nil return repeat eval))
(define-walker-template defun walk-defun)
;;; SBCL-only special forms
@@ -452,7 +452,7 @@
;;; FIXME: maybe we don't need this one any more, given that
;;; NAMED-LAMBDA now expands into (FUNCTION (NAMED-LAMBDA ...))?
(define-walker-template named-lambda walk-named-lambda)
-(define-walker-template sb-c::jump-table (nil eval repeat ((quote repeat (eval)))))
+(define-walker-template sb-c::jump-table (nil eval repeat (quote repeat eval)))
#|
;;; To find templateized symbols that aren't special operators:
(do-all-symbols (s)
@@ -648,7 +648,7 @@ instead of
(cond ((eq newnewnewform newnewform)
(if *walk-form-expand-macros-p* newnewform newform))
(t
- (record-new-source-path newform newnewnewform )))))
+ (record-new-source-path newform newnewnewform)))))
((and (symbolp fn)
(special-operator-p fn))
;; This shouldn't happen, since this walker is now
@@ -661,7 +661,7 @@ instead of
;; standard function call using a template for
;; standard function call.
(walk-template
- newnewform '(call repeat (eval)) context env))))))))))))))
+ newnewform '(call repeat eval) context env))))))))))))))
(defun record-new-source-path (old-form new-form)
(when (and *walk-form-preserve-source*
@@ -690,20 +690,8 @@ instead of
(t (walk-form-internal form context env)))))
(case (car template)
(repeat
- (walk-template-handle-repeat form
- (cdr template)
- ;; For the case where nothing
- ;; happens after the repeat
- ;; optimize away the call to
- ;; LENGTH.
- (if (null (cddr template))
- ()
- (nthcdr (- (length form)
- (length
- (cddr template)))
- form))
- context
- env))
+ (aver (null (cddr template)))
+ (walk-template-handle-repeat form (cadr template) context env))
(if
(walk-template form
(if (if (listp (cadr template))
@@ -723,38 +711,37 @@ instead of
(walk-template
(cdr form) (cdr template) context env))))))))
-(defun walk-template-handle-repeat (form template stop-form context env)
- (if (eq form stop-form)
- (walk-template form (cdr template) context env)
- (walk-template-handle-repeat-1
- form template (car template) stop-form context env)))
-
-(defun walk-template-handle-repeat-1 (form template repeat-template
- stop-form context env)
- (cond ((null form) ())
- ((eq form stop-form)
- (if (null repeat-template)
- (walk-template stop-form (cdr template) context env)
- (error "while handling code walker REPEAT:
- ~%ran into STOP while still in REPEAT template")))
- ((null repeat-template)
- (walk-template-handle-repeat-1
- form template (car template) stop-form context env))
- (t
- (recons form
- (walk-template (car form) (car repeat-template) context env)
- (walk-template-handle-repeat-1 (cdr form)
- template
- (cdr repeat-template)
- stop-form
- context
- env)))))
+(defun walk-template-handle-repeat (form template context env)
+ (let ((cdr form)
+ new)
+ (collect ((result))
+ (loop (when (atom cdr)
+ (if cdr
+ ;; A dotted list is not right, just return the original form
+ (return-from walk-template-handle-repeat form)
+ (return)))
+ (let* ((e (pop cdr))
+ (walked (walk-template e template context env)))
+ (cond (new
+ (result walked))
+ ((not (eq e walked))
+ (loop for (car . next) on form
+ until (eq next cdr)
+ do
+ (result car))
+ (result walked)
+ (setf new t)))))
+ (cond (new
+ (let ((result (result)))
+ (loop for old on form
+ for new on result
+ do (record-new-source-path old new))
+ result))
+ (t
+ form)))))
(defun walk-repeat-eval (form env)
- (and form
- (recons form
- (walk-form-internal (car form) :eval env)
- (walk-repeat-eval (cdr form) env))))
+ (walk-template-handle-repeat form 'eval :eval env))
(defun relist (x &rest args)
(if (null args)
diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index f8e25dd69..6a7adb0f8 100644
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -2831,3 +2831,9 @@
c)))
(assert (null (sb-mop:class-direct-subclasses (find-class 'super-class-cycle-forward-referenced-a))))
(defclass super-class-cycle-forward-referenced-b () ()))
+
+(with-test (:name :walking-long-progn)
+ (eval `(defmethod ,(gensym) ()
+ (macrolet ((gen (n)
+ `(progn ,@(make-list n :initial-element 1))))
+ (gen 100000)))))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL