From 41604a3f87290041f654728e76380d9a343e80db Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Fri, 30 Aug 2019 10:09:22 +0200
Subject: [PATCH] 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.
---
 optimizer.scm | 74 ++++++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 73 insertions(+), 1 deletion(-)

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
-- 
2.19.1