From 00d69b1c8c93cfbf714cbf820f78e4c6d0279983 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Sat, 18 May 2019 14:38:21 +0200 Subject: [PATCH] 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. --- NEWS | 4 ++ c-platform.scm | 151 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++- types.db | 57 +++++++--------------- 3 files changed, 172 insertions(+), 40 deletions(-) diff --git a/NEWS b/NEWS index 7b3a9790..919a8762 100644 --- a/NEWS +++ b/NEWS @@ -2,6 +2,10 @@ - Runtime system - 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 + ;; (* ) -> + ;; (* ...) -> (##core#inline "C_fixnum_times" (##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) + ;; (+ ) -> + ;; (+ ...) -> (##core#inline "C_fixnum_plus" (##core#inline "C_fixnum_plus" ...)) [fixnum-mode] + ;; (+ ...) -> (##core#inline "C_u_fixnum_plus" (##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) + ;; (- ) -> (##core#inline "C_fixnum_negate" ) [fixnum-mode] + ;; (- ) -> (##core#inline "C_u_fixnum_negate" ) [fixnum-mode + unsafe] + ;; (- ...) -> (##core#inline "C_fixnum_difference" (##core#inline "C_fixnum_difference" ...)) [fixnum-mode] + ;; (- ...) -> (##core#inline "C_u_fixnum_difference" (##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) + ;; (/ ...) -> (##core#inline "C_fixnum_divide" (##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 2) -> (##core#inline "C_fixnum_shift_right" 1) [fixnum-mode] + ;; (quotient ) -> (##core#inline "C_fixnum_divide" ) [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 6eff7d1f..3d274db4 100644 --- a/types.db +++ b/types.db @@ -64,8 +64,7 @@ (scheme#eqv? (#(procedure #:pure #:foldable) scheme#eqv? (* *) boolean) (((or immediate symbol) *) (scheme#eq? #(1) #(2))) - ((* (or immediate symbol)) (scheme#eq? #(1) #(2))) - ((* *) (##core#inline "C_i_eqvp" #(1) #(2)))) + ((* (or immediate symbol)) (scheme#eq? #(1) #(2)))) (scheme#equal? (#(procedure #:pure #:foldable) scheme#equal? (* *) boolean) (((or immediate symbol) *) (scheme#eq? #(1) #(2))) @@ -314,9 +313,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 +336,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 +362,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 +388,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 +427,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 +437,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 +447,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 +1057,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 -- 2.11.0