~ chicken-core (chicken-5) 0fcc20358eb98dd2e8f84ae0ce85e48cde8889ed
commit 0fcc20358eb98dd2e8f84ae0ce85e48cde8889ed
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Aug 30 10:09:22 2019 +0200
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sun Sep 15 11:42:24 2019 +0200
Add some optimizer simplification rules
Certain combinations of conditionals and ##core#inline operations turns
out to reduce the opportunity for collapsing continuation lambdas,
specifically, constructs like
(if ...
(let ((<var> (##core#inline ...)))
(<kvar> (##core#inline ... <var> ...)))
(<kvar> ...))
could not be optimized into a simpler form
(<kvar> ... (##core#cond ...) ...)
and thus not be contracted.
This patch rewrites the given form (and a variation using
##core#call) into a nested ##core#inline expression, making
the contraction possible.
diff --git a/optimizer.scm b/optimizer.scm
index 8017ef19..5d80ad12 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -792,7 +792,79 @@
(make-node
'if d
(list (make-node '##core#inline (list op) args)
- x y) ) ) ) ) )
+ x y) ) ) ) )
+
+ ;; (let ((<var1> (##core#inline <op1> ...)))
+ ;; (<var2> (##core#inline <op2> ... <var1> ...)))
+ ;; -> (<var2> (##core#inline <op2> ... (##core#inline <op2> ...)
+ ;; ...))
+ ;; - <var1> is used only once.
+ `((let (var) (##core#inline (op1) . args1)
+ (##core#call p
+ (##core#variable (kvar))
+ (##core#inline (op2) . args2)))
+ (var op1 args1 p kvar op2 args2)
+ ,(lambda (db may-rewrite var op1 args1 p kvar op2 args2)
+ (and may-rewrite ; give other optimizations a chance first
+ (not (eq? var kvar))
+ (not (db-get db kvar 'contractable))
+ (= 1 (length (db-get-list db var 'references)))
+ (let loop ((args args2) (nargs '()) (ok #f))
+ (cond ((null? args)
+ (and ok
+ (make-node
+ '##core#call p
+ (list (varnode kvar)
+ (make-node
+ '##core#inline
+ (list op2)
+ (reverse nargs))))))
+ ((and (eq? '##core#variable
+ (node-class (car args)))
+ (eq? var
+ (car (node-parameters (car args)))))
+ (loop (cdr args)
+ (cons (make-node
+ '##core#inline
+ (list op1)
+ args1)
+ nargs)
+ #t))
+ (else (loop (cdr args)
+ (cons (car args) nargs)
+ ok)))))))
+
+ ;; (let ((<var1> (##core#inline <op> ...)))
+ ;; (<var2> ... <var1> ...))
+ ;; -> (<var2> ... (##core#inline <op> ...) ...)
+ ;; ...))
+ ;; - <var1> is used only once.
+ `((let (var) (##core#inline (op) . args1)
+ (##core#call p . args2))
+ (var op args1 p args2)
+ ,(lambda (db may-rewrite var op args1 p args2)
+ (and may-rewrite ; give other optimizations a chance first
+ (= 1 (length (db-get-list db var 'references)))
+ (let loop ((args args2) (nargs '()) (ok #f))
+ (cond ((null? args)
+ (and ok
+ (make-node
+ '##core#call p
+ (reverse nargs))))
+ ((and (eq? '##core#variable
+ (node-class (car args)))
+ (eq? var
+ (car (node-parameters (car args)))))
+ (loop (cdr args)
+ (cons (make-node
+ '##core#inline
+ (list op)
+ args1)
+ nargs)
+ #t))
+ (else (loop (cdr args)
+ (cons (car args) nargs)
+ ok))))))))
(register-simplifications
Trap