From 9ea8c9f4887f7d30c231903759644d59d25d0938 Mon Sep 17 00:00:00 2001
From: Peter Bex <address@hidden>
Date: Wed, 23 Aug 2017 21:43:50 +0200
Subject: [PATCH] Rewrite vararg generic operators to dyadic ones

This allows for further optimizations because specialization rules are
only defined for dyadic versions of procedures, so even if all
argument types were known, vararg procedures would never be optimized
at all.

Now, even if not all types are known, we can at least specialize a few
intermediate operations.
---
 c-platform.scm | 14 ++++++++++++--
 optimizer.scm  | 53 ++++++++++++++++++++++++++---------------------------
 2 files changed, 38 insertions(+), 29 deletions(-)

diff --git a/c-platform.scm b/c-platform.scm
index 9f0554e7..864f371e 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -248,8 +248,6 @@
 
 ;;; Rewriting-definitions for this platform:
 
-(rewrite '+ 19 0 "C_fixnum_plus" "C_u_fixnum_plus" #f)
-
 (let ()
   ;; (add1 <x>) -> (##core#inline "C_fixnum_increase" <x>)     [fixnum-mode]
   ;; (add1 <x>) -> (##core#inline "C_u_fixnum_increase" <x>)   [fixnum-mode + unsafe]
@@ -579,6 +577,10 @@
 
 (rewrite 'abs 14 'fixnum 1 "C_fixnum_abs" "C_fixnum_abs")
 
+(rewrite 'chicken.bitwise#bitwise-and 19)
+(rewrite 'chicken.bitwise#bitwise-xor 19)
+(rewrite 'chicken.bitwise#bitwise-ior 19)
+
 (rewrite 'chicken.bitwise#bitwise-and 21 -1 "C_fixnum_and" "C_u_fixnum_and" "C_s_a_i_bitwise_and" 5)
 (rewrite 'chicken.bitwise#bitwise-xor 21 0 "C_fixnum_xor" "C_fixnum_xor" "C_s_a_i_bitwise_xor" 5)
 (rewrite 'chicken.bitwise#bitwise-ior 21 0 "C_fixnum_or" "C_u_fixnum_or" "C_s_a_i_bitwise_ior" 5)
@@ -663,10 +665,18 @@
 (rewrite 'lcm 12 '##sys#lcm #t 2)
 (rewrite 'chicken.data-structures#identity 12 #f #t 1)
 
+(rewrite 'gcd 19)
+(rewrite 'lcm 19)
+
 (rewrite 'gcd 18 0)
 (rewrite 'lcm 18 1)
 (rewrite 'list 18 '())
 
+(rewrite '+ 19)
+(rewrite '- 19)
+(rewrite '* 19)
+(rewrite '/ 19)
+
 (rewrite '+ 16 2 "C_s_a_i_plus" #t 29)
 (rewrite '- 16 2 "C_s_a_i_minus" #t 29)
 (rewrite '* 16 2 "C_s_a_i_times" #t 33)
diff --git a/optimizer.scm b/optimizer.scm
index 67f92374..e7d773da 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -1224,35 +1224,34 @@
 	  (intrinsic? name)
 	  (make-node '##core#call (list #t) (list cont (qnode (first classargs))) ) ) )
 
-    ;; (<op>) -> <id>
-    ;; (<op> <x>) -> <x>
-    ;; (<op> <x1> ...) -> (##core#inline <fixop> <x1> (##core#inline <fixop> ...)) [fixnum-mode]
-    ;; (<op> <x1> ...) -> (##core#inline <ufixop> <x1> (##core#inline <ufixop> ...)) [fixnum-mode + unsafe]
-    ;; - Remove "<id>" from arguments.
-    ((19) ; classargs = (<id> <fixop> <ufixop> <fixmode>)
+    ;; (<op> <x1> ... <xn>) -> (<op> (<op> <x1> ...) <xn>) [in CPS]
+    ((19)
      (and may-rewrite
 	  (intrinsic? name)
-	  (let* ((id (first classargs))
-		 (fixop (if unsafe (third classargs) (second classargs)))
-		 (callargs 
-		  (filter
-		   (lambda (x)
-		     (not (and (eq? 'quote (node-class x))
-			       (eq? id (first (node-parameters x))) ) ) )
-		   callargs) ) )
-	    (cond ((null? callargs) (make-node '##core#call (list #t) (list cont (qnode id))))
-		  ((null? (cdr callargs))
-		   (make-node '##core#call (list #t) (list cont (first callargs))) )
-		  ((or (fourth classargs) (eq? number-type 'fixnum))
-		   (make-node
-		    '##core#call (list #t)
-		    (list
-		     cont
-		     (fold-inner
-		      (lambda (x y)
-			(make-node '##core#inline (list fixop) (list x y)) )
-		      callargs) ) ) )
-		  (else #f) ) ) ) )
+	  (> (length callargs) 2)
+	  (let ((callargs (reverse callargs)))
+	    (let lp ((xn (car callargs))
+		     (xn-1 (cadr callargs))
+		     (rest (cddr callargs))
+		     (cont cont))
+	      (if (null? rest)
+		  (make-node
+		   '##core#call (list #t)
+		   (list (varnode name) cont xn-1 xn))
+		  (let ((r (gensym 'r))
+			(id (gensym 'va)))
+		    (make-node
+		     'let (list id)
+		     (list
+		      (make-node
+		       '##core#lambda (list id #t (list r) 0)
+		       (list (make-node
+			      '##core#call (list #t)
+			      (list (varnode name) cont (varnode r) xn)) ) )
+		      (lp xn-1
+			  (car rest)
+			  (cdr rest)
+			  (varnode id) ))) )))) ) )
 
     ;; (<op> ...) -> (##core#inline <iop> <arg1> ... (quote <x>) <argN>)
     ((20) ; classargs = (<argc> <iop> <x> <safe>)
-- 
2.11.0