~ chicken-core (chicken-5) c3441d1929b532e3b3e31d7fa848ccdc8ab697bb
commit c3441d1929b532e3b3e31d7fa848ccdc8ab697bb
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sat Apr 19 14:09:34 2025 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sat Apr 19 14:09:34 2025 +0200
remove clustering optimization as it was ineffective
diff --git a/batch-driver.scm b/batch-driver.scm
index 3afdb949..c5012c30 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -246,7 +246,6 @@
(and-let* ((pn (memq 'profile-name options))) (cadr pn)))
(hsize (memq 'heap-size options))
(kwstyle (memq 'keyword-style options))
- (loop/dispatch (memq 'clustering options))
(a-only (memq 'analyze-only options))
(do-scrutinize #t)
(do-lfa2 (memq 'lfa2 options))
@@ -773,9 +772,7 @@
;; Optimization loop:
(let loop ((i 1)
(node2 node1)
- (progress #t)
- (l/d #f)
- (l/d-done #f))
+ (progress #t))
(begin-time)
;; Analyze node tree for optimization
(let ([db (analyze 'opt node2 i progress)])
@@ -805,24 +802,19 @@
(debugging 'p "optimization pass" i)
(begin-time)
(receive (node2 progress-flag)
- (if l/d
- (determine-loop-and-dispatch node2 db)
(perform-high-level-optimizations
node2 db block-compilation
inline-locally inline-max-size
unroll-limit
- inline-substitutions-enabled))
+ inline-substitutions-enabled)
(end-time "optimization")
(print-node "optimized-iteration" '|5| node2)
(cond (progress-flag
- (loop (add1 i) node2 #t #f l/d))
- ((and (not l/d-done) loop/dispatch)
- (debugging 'p "clustering enabled")
- (loop (add1 i) node2 #t #t #t))
+ (loop (add1 i) node2 #t))
((not inline-substitutions-enabled)
(debugging 'p "rewritings enabled")
(set! inline-substitutions-enabled #t)
- (loop (add1 i) node2 #t #f l/d-done) )
+ (loop (add1 i) node2 #t) )
(optimize-leaf-routines
(begin-time)
(let ([db (analyze 'leaf node2)])
@@ -833,11 +825,9 @@
(end-time "leaf routine optimization")
(loop (add1 i)
node2
- progress
- #f
- l/d-done) ) ) )
+ progress) ) ) )
(else
- (loop (add1 i) node2 #f #f l/d-done)) ) ) )
+ (loop (add1 i) node2 #f)) ) ) )
(else
;; Secondary flow-analysis
diff --git a/chicken.mdoc b/chicken.mdoc
index cef12103..8bdd9efe 100644
--- a/chicken.mdoc
+++ b/chicken.mdoc
@@ -194,8 +194,6 @@ Disable procedure call checks only for usual bindings.
Disable procedure call checks for toplevel bindings.
.It Fl strict-types
Assume variable do not change their type.
-.It Fl clustering
-Combine groups of local procedures into dispatch loop.
.It Fl lfa2
Perform additional lightweight flow-analysis pass.
.It Fl unroll-limit Ar LIMIT
diff --git a/chicken.scm b/chicken.scm
index 5ec30fd1..b78a6423 100644
--- a/chicken.scm
+++ b/chicken.scm
@@ -102,7 +102,6 @@
(set! options
(cons* 'optimize-leaf-routines
'inline
- ;XXX 'clustering
'lfa2
options)) )
((3)
@@ -111,7 +110,6 @@
'inline
'inline-global
'local
- ;XXX 'clustering
'lfa2
'specialize
options) ) )
@@ -121,7 +119,6 @@
'inline
'inline-global
'specialize
- ;XXX 'clustering
'lfa2
'local 'unsafe
options) ) )
@@ -137,7 +134,6 @@
'no-lambda-info
'inline
'inline-global
- 'clustering
'lfa2
options) ) ) ) )
(loop (cdr rest)) ) )
diff --git a/csc.scm b/csc.scm
index 7deec9eb..099cde9b 100644
--- a/csc.scm
+++ b/csc.scm
@@ -152,7 +152,7 @@
-no-argc-checks -no-bound-checks -no-procedure-checks -no-compiler-syntax
-emit-all-import-libraries -no-elevation -module-registration -no-module-registration
-no-procedure-checks-for-usual-bindings -regenerate-import-libraries
- -specialize -strict-types -clustering -lfa2 -debug-info
+ -specialize -strict-types -lfa2 -debug-info
-no-procedure-checks-for-toplevel-bindings))
(define-constant complex-options
@@ -426,8 +426,6 @@ Usage: #{csc} [OPTION ...] [FILENAME ...]
disable procedure call checks for toplevel
bindings
-strict-types assume variable do not change their type
- -clustering combine groups of local procedures into dispatch
- loop
-lfa2 perform additional lightweight flow-analysis pass
-unroll-limit LIMIT specifies inlining limit for self-recursive calls
diff --git a/distribution/manifest b/distribution/manifest
index 19d8e4be..e18531a2 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -111,7 +111,6 @@ user-pass.scm
build-version.scm
build-version.c
buildid
-tests/clustering-tests.scm
tests/rest-arg-tests.scm
tests/csc-tests.scm
tests/c-id-valid.scm
diff --git a/manual/Using the compiler b/manual/Using the compiler
index c3b68d74..0b2ec9d2 100644
--- a/manual/Using the compiler
+++ b/manual/Using the compiler
@@ -30,8 +30,6 @@ the source text should be read from standard input.
; -check-syntax : Aborts compilation process after macro-expansion and syntax checks.
-; -clustering : Combine groups of local procedures into dispatch-loops, if possible.
-
; -consult-inline-file FILENAME : load file with definitions for cross-module inlining generated by a previous compiler invocation via {{-emit-inline-file}}. Implies {{-inline}}.
; -debug MODES : Enables one or more compiler debugging modes. {{MODES}} is a string of characters that select debugging information about the compiler that will be printed to standard output. Use {{-debug h}} to see a list of available debugging options.
@@ -152,7 +150,7 @@ the source text should be read from standard input.
</tr>
<tr>
<td>5 (or higher)</td>
-<td>{{-optimize-leaf-routines -block -inline -lfa2 -inline-global -specialize -unsafe -disable-interrupts -no-trace -no-lambda-info -clustering}}</td>
+<td>{{-optimize-leaf-routines -block -inline -lfa2 -inline-global -specialize -unsafe -disable-interrupts -no-trace -no-lambda-info}}</td>
<td>All possible optimizations, "unsafe"</td>
</tr>
</table>
diff --git a/optimizer.scm b/optimizer.scm
index 7d0a6610..e8b43b5b 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -31,7 +31,7 @@
(module chicken.compiler.optimizer
(scan-toplevel-assignments perform-high-level-optimizations
- transform-direct-lambdas! determine-loop-and-dispatch
+ transform-direct-lambdas!
eq-inline-operator membership-test-operators membership-unfold-limit
default-optimization-passes rewrite)
@@ -1748,207 +1748,4 @@
(walk #f node #f)
dirty) )
-
-;;; turn groups of local procedures into dispatch loop ("clustering")
-;
-; This turns (in bodies)
-;
-; :
-; (define (a x) (b x))
-; (define (b y) (a y))
-; (a z)))
-;
-; into something similar to
-;
-; (letrec ((<dispatch>
-; (lambda (<a1> <i>)
-; (case <i>
-; ((1) (let ((x <a1>)) (<dispatch> x 2)))
-; ((2) (let ((y <a1>)) (<dispatch> y 1)))
-; (else (<dispatch> z 1))))))
-; (<dispatch> #f 0))
-
-(define (determine-loop-and-dispatch node db)
- (let ((groups '())
- (outer #f)
- (group '()))
-
- (define (close) ; "close" group of local definitions
- (when (pair? group)
- (when (> (length group) 1)
- (set! groups (alist-cons outer group groups)))
- (set! group '())
- (set! outer #f)))
-
- (define (user-lambda? n)
- (and (eq? '##core#lambda (node-class n))
- (list? (third (node-parameters n))))) ; no rest argument allowed
-
- (define (walk n e)
- (let ((subs (node-subexpressions n))
- (params (node-parameters n))
- (class (node-class n)) )
- (case class
- ((let)
- (let ((var (first params))
- (val (first subs))
- (body (second subs)))
- (cond ((and (not outer)
- (eq? '##core#undefined (node-class val)))
- ;; find outermost "(let ((VAR (##core#undefined))) ...)"
- (set! outer n)
- (walk body (cons var e)))
- ((and outer
- (eq? 'set! (node-class val))
- (let ((sval (first (node-subexpressions val)))
- (svar (first (node-parameters val))))
- ;;XXX should we also accept "##core#direct_lambda" ?
- (and (eq? '##core#lambda (node-class sval))
- (= (length (db-get-list db svar 'references))
- (length (db-get-list db svar 'call-sites)))
- (memq svar e)
- (user-lambda? sval))))
- ;; "(set! VAR (lambda ...))" - add to group
- (set! group (cons val group))
- (walk body (cons var e)))
- (else
- ;; other "let" binding, close group (if any)
- (close)
- (walk val e)
- (walk body (cons var e))))))
- ((##core#lambda ##core#direct_lambda)
- (##sys#decompose-lambda-list
- (third params)
- (lambda (vars argc rest)
- ;; walk recursively, with cleared cluster state
- (fluid-let ((group '())
- (outer #f))
- (walk (first subs) vars)))))
- (else
- ;; other form, close group (if any)
- (close)
- (for-each (cut walk <> e) subs)))))
-
- (debugging 'p "collecting clusters ...")
-
- ;; walk once and gather groups
- (walk node '())
-
- ;; process found clusters
- (for-each
- (lambda (g)
- (let* ((outer (car g))
- (group (cdr g))
- (dname (gensym 'dispatch))
- (i (gensym 'i))
- (n 1)
- (bodies
- (map (lambda (assign)
- ;; collect information and replace assignment
- ;; with "(##core#undefined)"
- (let* ((name (first (node-parameters assign)))
- (proc (first (node-subexpressions assign)))
- (pparams (node-parameters proc))
- (llist (third pparams))
- (aliases (map gensym llist)))
- (##sys#decompose-lambda-list
- llist
- (lambda (vars argc rest)
- (let ((body (first (node-subexpressions proc)))
- (m n))
- (set! n (add1 n))
- (copy-node!
- (make-node '##core#undefined '() '())
- assign)
- (list name m llist body))))))
- group))
- (k (gensym 'k))
- (maxargs (apply max (map (o length third) bodies)))
- (dllist (append
- (list-tabulate maxargs (lambda _ (gensym 'a)))
- (list i))))
-
- (debugging 'x "clustering" (map first bodies)) ;XXX
-
- ;; first descend into "(let ((_ (##core#undefined))) ...)" forms
- ;; to make them visible everywhere
-
- (let descend ((outer outer))
- ;;(print "outer: " (node-parameters outer))
- (let ((body (second (node-subexpressions outer))))
- (if (and (eq? 'let (node-class body))
- (let ((val (first (node-subexpressions body))))
- (eq? '##core#undefined (node-class val))))
- (descend body)
- ;; wrap cluster into dispatch procedure
- (copy-node!
- (make-node
- 'let
- (list dname)
- (list
- (make-node '##core#undefined '() '())
- (make-node
- 'let (list (gensym))
- (list
- (make-node
- 'set! (list dname)
- (list
- (make-node
- '##core#lambda
- (list (gensym 'f_) #t dllist 0)
- (list
- ;; dispatch to cluster member or main body
- (make-node
- '##core#switch
- (list (sub1 n))
- (append
- (list (varnode i))
- (append-map
- (lambda (b)
- (list (qnode (second b))
- (let loop ((args dllist)
- (vars (third b)))
- (if (null? vars)
- (fourth b)
- (make-node
- 'let (list (car vars))
- (list (varnode (car args))
- (loop (cdr args) (cdr vars))))))))
- bodies)
- (cdr (node-subexpressions outer))))))))
- ;; call to enter dispatch loop - the current continuation is
- ;; not used, so the first parameter is passed as "#f" (it is
- ;; a tail call)
- (make-node
- '##core#call '(#t)
- (cons* (varnode dname)
- (append
- (list-tabulate maxargs (lambda _ (qnode #f)))
- (list (qnode 0)))))))))
- outer))))
-
- ;; modify call-sites to invoke dispatch loop instead
- (for-each
- (lambda (b)
- (let ((sites (db-get db (car b) 'call-sites)))
- (for-each
- (lambda (site)
- (let* ((callnode (cdr site))
- (args (cdr (node-subexpressions callnode))))
- (copy-node!
- (make-node
- '##core#call (node-parameters callnode)
- (cons* (varnode dname)
- (append
- args
- (list-tabulate
- (- maxargs (length args))
- (lambda _ (qnode #f)))
- (list (qnode (second b))))))
- callnode)))
- sites)))
- bodies)))
-
- groups)
- (values node (pair? groups))))
)
diff --git a/support.scm b/support.scm
index b81b00b3..31e434cb 100644
--- a/support.scm
+++ b/support.scm
@@ -1853,8 +1853,6 @@ Usage: chicken FILENAME [OPTION ...]
disable procedure call checks for toplevel
bindings
-strict-types assume variable do not change their type
- -clustering combine groups of local procedures into dispatch
- loop
-lfa2 perform additional lightweight flow-analysis pass
-unroll-limit LIMIT specifies inlining limit for self-recursive calls
diff --git a/tests/clustering-tests.scm b/tests/clustering-tests.scm
index 92fec92f..e69de29b 100644
--- a/tests/clustering-tests.scm
+++ b/tests/clustering-tests.scm
@@ -1,7 +0,0 @@
-;;; clustering-tests.scm
-
-;; triggers `determine-loop-and-dispatch`
-(let ()
- (define (a x) (if (= x 0) x (b (sub1 x))))
- (define (b x) (if (= x 0) x (a (sub1 x))))
- (a 10))
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 5981b76c..6561cf28 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -106,9 +106,6 @@ $compile -analyze-only messages-test.scm 2>messages.out
diff $DIFF_OPTS messages.expected messages.out
echo "======================================== optimizer tests ..."
-$compile clustering-tests.scm -clustering
-./a.out
-
$compile rest-arg-tests.scm -specialize
./a.out
Trap