~ chicken-core (chicken-5) 47337654081921efbe7ac6ce32848993daf243a0
commit 47337654081921efbe7ac6ce32848993daf243a0
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Wed Aug 23 21:43:50 2017 +0200
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Fri Sep 1 12:40:05 2017 -0400
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.
Signed-off-by: Evan Hanson <evhan@foldling.org>
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..6286265a 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>)
Trap