~ chicken-core (chicken-5) bc72c05fa61581fc1fa86e90000a002847c3f28b
commit bc72c05fa61581fc1fa86e90000a002847c3f28b
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed May 29 11:03:01 2019 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed May 29 11:03:01 2019 +0200
Fix the most of #1604 by restoring rewrites dropped in
61af5f1
To make this work, we must remove the numeric operator rewrites
for (* *) in types.db, and instead rely on the rewrites in
c-platform.scm (which were already there), because specialization
happens before optimization. So in the generic case, we'll end up
with the same code, but in fixnum arithmetic we'll end up with the
fixnum-specific versions.
Unfortunately, this still means that if the scrutinizer detects that
arguments are known to be integers (but not certain to be fixnums),
we'll generate calls to the more generic C_s_a_u_i_integer_... C
functions. If they're known to be fixnums, we'll generate calls to
C_a_i_fixnum_..., which can overflow into bignums. This is still not
optimal in fixnum arithmetic mode, because in that mode we'd want to
unsafely ignore overflow.
(Patch originally by Peter Bex)
Signed-off-by: felix <felix@call-with-current-continuation.org>
diff --git a/NEWS b/NEWS
index ee173e0c..84505a56 100644
--- a/NEWS
+++ b/NEWS
@@ -4,6 +4,10 @@
- Keywords are now distinct types; they are not a subtype of symbols.
- Use arc4random on FreeBSD (thanks to Tobias Kortkamp and gahr)
+- Compiler
+ - Restored optimized implementations of =, +, -, /, * and quotient in
+ fixnum-arithmetic mode (fixes #1604 mostly; thanks to "chickendan").
+
5.0.2
- Core libraries
diff --git a/c-platform.scm b/c-platform.scm
index 03f356ce..f5206e91 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -258,7 +258,7 @@
(append +fixnum-bindings+ +flonum-bindings+ +extended-bindings+))
(set! internal-bindings
- '(##sys#slot ##sys#setslot ##sys#block-ref ##sys#block-set!
+ '(##sys#slot ##sys#setslot ##sys#block-ref ##sys#block-set! ##sys#/-2
##sys#call-with-current-continuation ##sys#size ##sys#byte ##sys#setbyte
##sys#pointer? ##sys#generic-structure? ##sys#structure? ##sys#check-structure
##sys#check-exact ##sys#check-number ##sys#check-list ##sys#check-pair ##sys#check-string
@@ -725,6 +725,155 @@
(rewrite 'scheme#lcm 18 1)
(rewrite 'scheme#list 18 '())
+(rewrite
+ 'scheme#* 8
+ (lambda (db classargs cont callargs)
+ ;; (*) -> 1
+ ;; (* <x>) -> <x>
+ ;; (* <x1> ...) -> (##core#inline "C_fixnum_times" <x1> (##core#inline "C_fixnum_times" ...)) [fixnum-mode]
+ ;; - Remove "1" from arguments.
+ ;; - Replace multiplications with 2 by shift left. [fixnum-mode]
+ (let ((callargs
+ (filter
+ (lambda (x)
+ (not (and (eq? 'quote (node-class x))
+ (eq? 1 (first (node-parameters x))) ) ) )
+ callargs) ) )
+ (cond ((null? callargs) (make-node '##core#call (list #t) (list cont (qnode 0))))
+ ((null? (cdr callargs))
+ (make-node '##core#call (list #t) (list cont (first callargs))) )
+ ((eq? number-type 'fixnum)
+ (make-node
+ '##core#call (list #t)
+ (list
+ cont
+ (fold-inner
+ (lambda (x y)
+ (if (and (eq? 'quote (node-class y)) (eq? 2 (first (node-parameters y))))
+ (make-node '##core#inline '("C_fixnum_shift_left") (list x (qnode 1)))
+ (make-node '##core#inline '("C_fixnum_times") (list x y)) ) )
+ callargs) ) ) )
+ (else #f) ) ) ) )
+
+(rewrite
+ 'scheme#+ 8
+ (lambda (db classargs cont callargs)
+ ;; (+ <x>) -> <x>
+ ;; (+ <x1> ...) -> (##core#inline "C_fixnum_plus" <x1> (##core#inline "C_fixnum_plus" ...)) [fixnum-mode]
+ ;; (+ <x1> ...) -> (##core#inline "C_u_fixnum_plus" <x1> (##core#inline "C_u_fixnum_plus" ...))
+ ;; [fixnum-mode + unsafe]
+ ;; - Remove "0" from arguments, if more than 1.
+ (cond ((or (null? callargs) (not (eq? number-type 'fixnum))) #f)
+ ((null? (cdr callargs))
+ (make-node
+ '##core#call (list #t)
+ (list cont
+ (make-node '##core#inline
+ (if unsafe '("C_u_fixnum_plus") '("C_fixnum_plus"))
+ callargs)) ) )
+ (else
+ (let ((callargs
+ (cons (car callargs)
+ (filter
+ (lambda (x)
+ (not (and (eq? 'quote (node-class x))
+ (zero? (first (node-parameters x))) ) ) )
+ (cdr callargs) ) ) ) )
+ (and (>= (length callargs) 2)
+ (make-node
+ '##core#call (list #t)
+ (list
+ cont
+ (fold-inner
+ (lambda (x y)
+ (make-node '##core#inline
+ (if unsafe '("C_u_fixnum_plus") '("C_fixnum_plus"))
+ (list x y) ) )
+ callargs) ) ) ) ) ) ) ) )
+
+(rewrite
+ 'scheme#- 8
+ (lambda (db classargs cont callargs)
+ ;; (- <x>) -> (##core#inline "C_fixnum_negate" <x>) [fixnum-mode]
+ ;; (- <x>) -> (##core#inline "C_u_fixnum_negate" <x>) [fixnum-mode + unsafe]
+ ;; (- <x1> ...) -> (##core#inline "C_fixnum_difference" <x1> (##core#inline "C_fixnum_difference" ...)) [fixnum-mode]
+ ;; (- <x1> ...) -> (##core#inline "C_u_fixnum_difference" <x1> (##core#inline "C_u_fixnum_difference" ...))
+ ;; [fixnum-mode + unsafe]
+ ;; - Remove "0" from arguments, if more than 1.
+ (cond ((or (null? callargs) (not (eq? number-type 'fixnum))) #f)
+ ((null? (cdr callargs))
+ (make-node
+ '##core#call (list #t)
+ (list cont
+ (make-node '##core#inline
+ (if unsafe '("C_u_fixnum_negate") '("C_fixnum_negate"))
+ callargs)) ) )
+ (else
+ (let ((callargs
+ (cons (car callargs)
+ (filter
+ (lambda (x)
+ (not (and (eq? 'quote (node-class x))
+ (zero? (first (node-parameters x))) ) ) )
+ (cdr callargs) ) ) ) )
+ (and (>= (length callargs) 2)
+ (make-node
+ '##core#call (list #t)
+ (list
+ cont
+ (fold-inner
+ (lambda (x y)
+ (make-node '##core#inline
+ (if unsafe '("C_u_fixnum_difference") '("C_fixnum_difference"))
+ (list x y) ) )
+ callargs) ) ) ) ) ) ) ) )
+
+(let ()
+ (define (rewrite-div db classargs cont callargs)
+ ;; (/ <x1> ...) -> (##core#inline "C_fixnum_divide" <x1> (##core#inline "C_fixnum_divide" ...)) [fixnum-mode]
+ ;; - Remove "1" from arguments, if more than 1.
+ ;; - Replace divisions by 2 with shift right. [fixnum-mode]
+ (and (eq? number-type 'fixnum)
+ (>= (length callargs) 2)
+ (let ((callargs
+ (cons (car callargs)
+ (filter
+ (lambda (x)
+ (not (and (eq? 'quote (node-class x))
+ (eq? 1 (first (node-parameters x))) ) ) )
+ (cdr callargs) ) ) ) )
+ (and (>= (length callargs) 2)
+ (make-node
+ '##core#call (list #t)
+ (list
+ cont
+ (fold-inner
+ (lambda (x y)
+ (if (and (eq? 'quote (node-class y)) (eq? 2 (first (node-parameters y))))
+ (make-node '##core#inline '("C_fixnum_shift_right") (list x (qnode 1)))
+ (make-node '##core#inline '("C_fixnum_divide") (list x y)) ) )
+ callargs) ) ) ) ) ) )
+ (rewrite 'scheme#/ 8 rewrite-div)
+ (rewrite '##sys#/-2 8 rewrite-div))
+
+(rewrite
+ 'scheme#quotient 8
+ (lambda (db classargs cont callargs)
+ ;; (quotient <x> 2) -> (##core#inline "C_fixnum_shift_right" <x> 1) [fixnum-mode]
+ ;; (quotient <x> <y>) -> (##core#inline "C_fixnum_divide" <x> <y>) [fixnum-mode]
+ (and (eq? 'fixnum number-type)
+ (= (length callargs) 2)
+ (make-node
+ '##core#call (list #t)
+ (let ([arg2 (second callargs)])
+ (list cont
+ (if (and (eq? 'quote (node-class arg2))
+ (eq? 2 (first (node-parameters arg2))) )
+ (make-node
+ '##core#inline '("C_fixnum_shift_right")
+ (list (first callargs) (qnode 1)) )
+ (make-node '##core#inline '("C_fixnum_divide") callargs) ) ) ) ) ) ) )
+
(rewrite 'scheme#+ 19)
(rewrite 'scheme#- 19)
(rewrite 'scheme#* 19)
diff --git a/types.db b/types.db
index 01f76ec6..59ea9250 100644
--- a/types.db
+++ b/types.db
@@ -314,9 +314,7 @@
((fixnum fixnum) (integer)
(##core#inline_allocate ("C_a_i_fixnum_plus" 5) #(1) #(2)))
((integer integer) (integer)
- (##core#inline_allocate ("C_s_a_u_i_integer_plus" 5) #(1) #(2)))
- ((* *) (number)
- (##core#inline_allocate ("C_s_a_i_plus" 29) #(1) #(2))))
+ (##core#inline_allocate ("C_s_a_u_i_integer_plus" 5) #(1) #(2))))
(scheme#- (#(procedure #:clean #:enforce #:foldable) scheme#- (number #!rest number) number)
((fixnum) (integer) (##core#inline_allocate ("C_a_i_fixnum_negate" 5) #(1)))
@@ -339,9 +337,7 @@
((fixnum fixnum) (integer)
(##core#inline_allocate ("C_a_i_fixnum_difference" 5) #(1) #(2)))
((integer integer) (integer)
- (##core#inline_allocate ("C_s_a_u_i_integer_minus" 5) #(1) #(2)))
- ((* *) (number)
- (##core#inline_allocate ("C_s_a_i_minus" 29) #(1) #(2))))
+ (##core#inline_allocate ("C_s_a_u_i_integer_minus" 5) #(1) #(2))))
(scheme#* (#(procedure #:clean #:enforce #:foldable) scheme#* (#!rest number) number)
(() (fixnum) '1)
@@ -367,9 +363,7 @@
((fixnum fixnum) (integer)
(##core#inline_allocate ("C_a_i_fixnum_times" 5) #(1) #(2)))
((integer integer) (integer)
- (##core#inline_allocate ("C_s_a_u_i_integer_times" 5) #(1) #(2)))
- ((* *) (number)
- (##core#inline_allocate ("C_s_a_i_times" 33) #(1) #(2))))
+ (##core#inline_allocate ("C_s_a_u_i_integer_times" 5) #(1) #(2))))
(scheme#/ (#(procedure #:clean #:enforce #:foldable) scheme#/ (number #!rest number) number)
((float fixnum) (float)
@@ -395,40 +389,35 @@
((number) (let ((#(tmp) #(1))) '#t))
((fixnum fixnum) (scheme#eq? #(1) #(2)))
((float float) (##core#inline "C_flonum_equalp" #(1) #(2)))
- ((integer integer) (##core#inline "C_i_integer_equalp" #(1) #(2)))
- ((* *) (##core#inline "C_i_nequalp" #(1) #(2))))
+ ((integer integer) (##core#inline "C_i_integer_equalp" #(1) #(2))))
(scheme#> (#(procedure #:clean #:enforce #:foldable) scheme#> (#!rest number) boolean)
(() '#t)
((number) (let ((#(tmp) #(1))) '#t))
((fixnum fixnum) (chicken.fixnum#fx> #(1) #(2)))
((float float) (##core#inline "C_flonum_greaterp" #(1) #(2)))
- ((integer integer) (##core#inline "C_i_integer_greaterp" #(1) #(2)))
- ((* *) (##core#inline "C_i_greaterp" #(1) #(2))))
+ ((integer integer) (##core#inline "C_i_integer_greaterp" #(1) #(2))))
(scheme#< (#(procedure #:clean #:enforce #:foldable) scheme#< (#!rest number) boolean)
(() '#t)
((number) (let ((#(tmp) #(1))) '#t))
((fixnum fixnum) (chicken.fixnum#fx< #(1) #(2)))
((integer integer) (##core#inline "C_i_integer_lessp" #(1) #(2)))
- ((float float) (##core#inline "C_flonum_lessp" #(1) #(2)))
- ((* *) (##core#inline "C_i_lessp" #(1) #(2))))
+ ((float float) (##core#inline "C_flonum_lessp" #(1) #(2))))
(scheme#>= (#(procedure #:clean #:enforce #:foldable) scheme#>= (#!rest number) boolean)
(() '#t)
((number) (let ((#(tmp) #(1))) '#t))
((fixnum fixnum) (chicken.fixnum#fx>= #(1) #(2)))
((integer integer) (##core#inline "C_i_integer_greater_or_equalp" #(1) #(2)))
- ((float float) (##core#inline "C_flonum_greater_or_equal_p" #(1) #(2)))
- ((* *) (##core#inline "C_i_greater_or_equalp" #(1) #(2))))
+ ((float float) (##core#inline "C_flonum_greater_or_equal_p" #(1) #(2))))
(scheme#<= (#(procedure #:clean #:enforce #:foldable) scheme#<= (#!rest number) boolean)
(() '#t)
((number) (let ((#(tmp) #(1))) '#t))
((fixnum fixnum) (chicken.fixnum#fx<= #(1) #(2)))
((integer integer) (##core#inline "C_i_integer_less_or_equalp" #(1) #(2)))
- ((float float) (##core#inline "C_flonum_less_or_equal_p" #(1) #(2)))
- ((* *) (##core#inline "C_i_less_or_equalp" #(1) #(2))))
+ ((float float) (##core#inline "C_flonum_less_or_equal_p" #(1) #(2))))
(scheme#quotient (#(procedure #:clean #:enforce #:foldable) scheme#quotient ((or integer float) (or integer float)) (or integer float))
;;XXX flonum/mixed case
@@ -439,8 +428,7 @@
(##core#inline_allocate ("C_a_i_fixnum_quotient_checked" 5)
#(1) #(2)))
((integer integer) (integer)
- (##core#inline_allocate ("C_s_a_u_i_integer_quotient" 5) #(1) #(2)))
- ((* *) (##core#inline_allocate ("C_s_a_i_quotient" 5) #(1) #(2))))
+ (##core#inline_allocate ("C_s_a_u_i_integer_quotient" 5) #(1) #(2))))
(scheme#remainder (#(procedure #:clean #:enforce #:foldable) scheme#remainder ((or integer float) (or integer float)) (or integer float))
((float float) (float)
@@ -450,8 +438,7 @@
((fixnum fixnum) (fixnum)
(##core#inline "C_i_fixnum_remainder_checked" #(1) #(2)))
((integer integer) (integer)
- (##core#inline_allocate ("C_s_a_u_i_integer_remainder" 5) #(1) #(2)))
- ((* *) (##core#inline_allocate ("C_s_a_i_remainder" 5) #(1) #(2))))
+ (##core#inline_allocate ("C_s_a_u_i_integer_remainder" 5) #(1) #(2))))
(scheme#modulo (#(procedure #:clean #:enforce #:foldable) scheme#modulo ((or integer float) (or integer float)) (or integer float))
((float float) (float)
@@ -461,8 +448,7 @@
((fixnum fixnum) (fixnum)
(##core#inline "C_fixnum_modulo" #(1) #(2)))
((integer integer) (integer)
- (##core#inline_allocate ("C_s_a_u_i_integer_modulo" 5) #(1) #(2)))
- ((* *) (##core#inline_allocate ("C_s_a_i_modulo" 5) #(1) #(2))))
+ (##core#inline_allocate ("C_s_a_u_i_integer_modulo" 5) #(1) #(2))))
(scheme#gcd (#(procedure #:clean #:enforce #:foldable) scheme#gcd (#!rest (or integer float)) (or integer float))
(() '0)
@@ -1072,41 +1058,35 @@
((*) (##core#inline "C_i_integer_length" #(1))))
(chicken.bitwise#arithmetic-shift
- (#(procedure #:clean #:enforce #:foldable) chicken.bitwise#arithmetic-shift (integer fixnum) integer)
- ((* *) (##core#inline_allocate ("C_s_a_i_arithmetic_shift" 5) #(1) #(2))))
+ (#(procedure #:clean #:enforce #:foldable) chicken.bitwise#arithmetic-shift (integer fixnum) integer))
(chicken.bitwise#bit->boolean
(#(procedure #:clean #:enforce #:foldable) chicken.bitwise#bit->boolean (integer integer) boolean)
- ((fixnum fixnum) (##core#inline "C_i_fixnum_bit_to_bool" #(1) #(2)))
- ((* *) (##core#inline "C_i_bit_to_bool" #(1) #(2))))
+ ((fixnum fixnum) (##core#inline "C_i_fixnum_bit_to_bool" #(1) #(2))))
(chicken.bitwise#bitwise-and
(#(procedure #:clean #:enforce #:foldable) chicken.bitwise#bitwise-and (#!rest integer) integer)
(() '-1)
((fixnum) (fixnum) #(1))
((integer) #(1))
- ((fixnum fixnum) (fixnum) (##core#inline "C_u_fixnum_and" #(1) #(2)))
- ((* *) (##core#inline_allocate ("C_s_a_i_bitwise_and" 5) #(1) #(2))))
+ ((fixnum fixnum) (fixnum) (##core#inline "C_u_fixnum_and" #(1) #(2))))
(chicken.bitwise#bitwise-ior
(#(procedure #:clean #:enforce #:foldable) chicken.bitwise#bitwise-ior (#!rest integer) integer)
(() '0)
((fixnum) (fixnum) #(1))
((integer) #(1))
- ((fixnum fixnum) (fixnum) (##core#inline "C_u_fixnum_or" #(1) #(2)))
- ((* *) (##core#inline_allocate ("C_s_a_i_bitwise_ior" 5) #(1) #(2))))
+ ((fixnum fixnum) (fixnum) (##core#inline "C_u_fixnum_or" #(1) #(2))))
(chicken.bitwise#bitwise-xor
(#(procedure #:clean #:enforce #:foldable) chicken.bitwise#bitwise-xor (#!rest integer) integer)
(() '0)
((fixnum) (fixnum) #(1))
((integer) #(1))
- ((fixnum fixnum) (fixnum) (##core#inline "C_fixnum_xor" #(1) #(2)))
- ((* *) (##core#inline_allocate ("C_s_a_i_bitwise_xor" 5) #(1) #(2))))
+ ((fixnum fixnum) (fixnum) (##core#inline "C_fixnum_xor" #(1) #(2))))
(chicken.bitwise#bitwise-not
- (#(procedure #:clean #:enforce #:foldable) chicken.bitwise#bitwise-not (integer) integer)
- ((* *) (##core#inline_allocate ("C_s_a_i_bitwise_not" 5) #(1))))
+ (#(procedure #:clean #:enforce #:foldable) chicken.bitwise#bitwise-not (integer) integer))
;; blob
Trap