Ludovic Courtès <l...@gnu.org> skribis:
> ludo@ribbon ~/src/guix$ ./pre-inst-env guix environment --pure --ad-hoc
> guile-next guile3.0-hashing -- guile ~/tmp/sha256.scm
>
> ;;; (hash "b33576331465a60b003573541bf3b1c205936a16c407bc69f8419a527bf5c988")
> clock utime stime cutime cstime gctime
> 65.17 89.75 0.45 0.00 0.00 35.63
The patch below gives us:
--8<---------------cut here---------------start------------->8---
ludo@ribbon /tmp/hashing$ guile --r6rs -L .. ~/tmp/sha256.scm
;;; (hash "b33576331465a60b003573541bf3b1c205936a16c407bc69f8419a527bf5c988")
clock utime stime cutime cstime gctime
59.31 80.65 0.39 0.00 0.00 30.73
--8<---------------cut here---------------end--------------->8---
It’s a disappointingly small improvement. The reason is that (hashing
fixnums) adds another layer of opacity, where it ends up doing
essentially:
(define fx32xor fxxor)
…
Thus, no inlining, and no easy trick to solve that. :-/
Anyhow, I think the patch is probably a good idea. WDYT?
Thanks,
Ludo’.
diff --git a/module/rnrs/arithmetic/fixnums.scm b/module/rnrs/arithmetic/fixnums.scm
index 4ec1cae0c..c30807eb5 100644
--- a/module/rnrs/arithmetic/fixnums.scm
+++ b/module/rnrs/arithmetic/fixnums.scm
@@ -1,6 +1,6 @@
;;; fixnums.scm --- The R6RS fixnums arithmetic library
-;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011, 2013, 2020 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -75,25 +75,26 @@
fxrotate-bit-field
fxreverse-bit-field)
(import (only (guile) ash
- cons*
- define-inlinable
- inexact->exact
- logand
- logbit?
- logcount
- logior
- lognot
- logxor
- most-positive-fixnum
- most-negative-fixnum
- object-address)
+ cons*
+ define-inlinable
+ inexact->exact
+ logand
+ logbit?
+ logcount
+ logior
+ lognot
+ logxor
+ most-positive-fixnum
+ most-negative-fixnum
+ object-address)
(ice-9 optargs)
(rnrs base (6))
(rnrs control (6))
(rnrs arithmetic bitwise (6))
(rnrs conditions (6))
(rnrs exceptions (6))
- (rnrs lists (6)))
+ (rnrs lists (6))
+ (rnrs syntax-case (6)))
(define fixnum-width
(let ((w (do ((i 0 (+ 1 i))
@@ -121,70 +122,105 @@
(or (for-all inline-fixnum? args) (raise (make-assertion-violation))))
(define-syntax define-fxop*
+ (lambda (s)
+ (syntax-case s ()
+ ((_ name op)
+ (with-syntax ((proc (datum->syntax
+ #'name
+ (string->symbol
+ (string-append "%"
+ (symbol->string
+ (syntax->datum #'name))
+ "-proc")))))
+ #'(begin
+ ;; Define a procedure for when the inline case doesn't
+ ;; apply.
+ (define proc
+ (case-lambda
+ ((x y)
+ (assert-fixnum x y)
+ (op x y))
+ (args
+ (assert-fixnums args)
+ (apply op args))))
+
+ (define-syntax name
+ (lambda (s)
+ (syntax-case s ()
+ ((_ args (... ...))
+ #'(begin
+ (assert-fixnum args (... ...))
+ (op args (... ...))))
+ (x
+ (identifier? #'x)
+ #'proc))))))))))
+
+ (define-syntax define-alias
(syntax-rules ()
- ((_ name op)
- (define name
- (case-lambda
- ((x y)
- (assert-fixnum x y)
- (op x y))
- (args
- (assert-fixnums args)
- (apply op args)))))))
+ ((_ new old)
+ (define-syntax new (identifier-syntax old)))))
;; All these predicates don't check their arguments for fixnum-ness,
;; as this doesn't seem to be strictly required by R6RS.
- (define fx=? =)
- (define fx>? >)
- (define fx<? <)
- (define fx>=? >=)
- (define fx<=? <=)
+ (define-alias fx=? =)
+ (define-alias fx>? >)
+ (define-alias fx<? <)
+ (define-alias fx>=? >=)
+ (define-alias fx<=? <=)
- (define fxzero? zero?)
- (define fxpositive? positive?)
- (define fxnegative? negative?)
- (define fxodd? odd?)
- (define fxeven? even?)
+ (define-alias fxzero? zero?)
+ (define-alias fxpositive? positive?)
+ (define-alias fxnegative? negative?)
+ (define-alias fxodd? odd?)
+ (define-alias fxeven? even?)
(define-fxop* fxmax max)
(define-fxop* fxmin min)
- (define (fx+ fx1 fx2)
+ (define-inlinable (fx+ fx1 fx2)
(assert-fixnum fx1 fx2)
(let ((r (+ fx1 fx2)))
(or (inline-fixnum? r)
(raise (make-implementation-restriction-violation)))
r))
- (define (fx* fx1 fx2)
+ (define-inlinable (fx* fx1 fx2)
(assert-fixnum fx1 fx2)
(let ((r (* fx1 fx2)))
(or (inline-fixnum? r)
(raise (make-implementation-restriction-violation)))
r))
- (define* (fx- fx1 #:optional fx2)
- (assert-fixnum fx1)
- (if fx2
- (begin
- (assert-fixnum fx2)
- (let ((r (- fx1 fx2)))
- (or (inline-fixnum? r) (raise (make-assertion-violation)))
- r))
- (let ((r (- fx1)))
- (or (inline-fixnum? r) (raise (make-assertion-violation)))
- r)))
-
- (define (fxdiv fx1 fx2)
+ (define-syntax fx-
+ (lambda (s)
+ (syntax-case s ()
+ ((_ fx)
+ #'(begin
+ (assert-fixnum fx)
+ (let ((r (- fx)))
+ (unless (inline-fixnum? r) (raise (make-assertion-violation)))
+ (- fx))))
+ ((_ fx1 fx2)
+ #'(begin
+ (assert-fixnum fx1)
+ (assert-fixnum fx2)
+ (let ((r (- fx1 fx2)))
+ (unless (inline-fixnum? r) (raise (make-assertion-violation)))
+ r)))
+ (x
+ (identifier? #'x)
+ #'-))))
+
+ (define-inlinable (fxdiv fx1 fx2)
(assert-fixnum fx1 fx2)
(div fx1 fx2))
- (define (fxmod fx1 fx2)
+ (define-inlinable (fxmod fx1 fx2)
(assert-fixnum fx1 fx2)
(mod fx1 fx2))
- (define (fxdiv-and-mod fx1 fx2)
+ (define-inlinable (fxdiv-and-mod fx1 fx2)
(assert-fixnum fx1 fx2)
(div-and-mod fx1 fx2))
@@ -221,71 +257,71 @@
(s1 (div0 s (expt 2 (fixnum-width)))))
(values s0 s1)))
- (define (fxnot fx) (assert-fixnum fx) (lognot fx))
+ (define-inlinable (fxnot fx) (assert-fixnum fx) (lognot fx))
(define-fxop* fxand logand)
(define-fxop* fxior logior)
(define-fxop* fxxor logxor)
- (define (fxif fx1 fx2 fx3)
+ (define-inlinable (fxif fx1 fx2 fx3)
(assert-fixnum fx1 fx2 fx3)
(bitwise-if fx1 fx2 fx3))
- (define (fxbit-count fx)
+ (define-inlinable (fxbit-count fx)
(assert-fixnum fx)
(if (negative? fx)
(bitwise-not (logcount fx))
(logcount fx)))
- (define (fxlength fx) (assert-fixnum fx) (bitwise-length fx))
- (define (fxfirst-bit-set fx) (assert-fixnum fx) (bitwise-first-bit-set fx))
- (define (fxbit-set? fx1 fx2) (assert-fixnum fx1 fx2) (logbit? fx2 fx1))
+ (define-inlinable (fxlength fx) (assert-fixnum fx) (bitwise-length fx))
+ (define-inlinable (fxfirst-bit-set fx) (assert-fixnum fx) (bitwise-first-bit-set fx))
+ (define-inlinable (fxbit-set? fx1 fx2) (assert-fixnum fx1 fx2) (logbit? fx2 fx1))
- (define (fxcopy-bit fx1 fx2 fx3)
+ (define-inlinable (fxcopy-bit fx1 fx2 fx3)
(assert-fixnum fx1 fx2 fx3)
(unless (and (<= 0 fx2) (< fx2 (fixnum-width)))
(raise (make-assertion-violation)))
(bitwise-copy-bit fx1 fx2 fx3))
- (define (fxbit-field fx1 fx2 fx3)
+ (define-inlinable (fxbit-field fx1 fx2 fx3)
(assert-fixnum fx1 fx2 fx3)
(unless (and (<= 0 fx2 fx3) (< fx3 (fixnum-width)))
(raise (make-assertion-violation)))
(bitwise-bit-field fx1 fx2 fx3))
- (define (fxcopy-bit-field fx1 fx2 fx3 fx4)
+ (define-inlinable (fxcopy-bit-field fx1 fx2 fx3 fx4)
(assert-fixnum fx1 fx2 fx3 fx4)
(unless (and (<= 0 fx2 fx3) (< fx3 (fixnum-width)))
(raise (make-assertion-violation)))
(bitwise-copy-bit-field fx1 fx2 fx3 fx4))
- (define (fxarithmetic-shift fx1 fx2)
+ (define-inlinable (fxarithmetic-shift fx1 fx2)
(assert-fixnum fx1 fx2)
(unless (< (abs fx2) (fixnum-width))
(raise (make-assertion-violation)))
(ash fx1 fx2))
- (define (fxarithmetic-shift-left fx1 fx2)
+ (define-inlinable (fxarithmetic-shift-left fx1 fx2)
(assert-fixnum fx1 fx2)
(unless (and (<= 0 fx2) (< fx2 (fixnum-width)))
(raise (make-assertion-violation)))
(ash fx1 fx2))
- (define (fxarithmetic-shift-right fx1 fx2)
+ (define-inlinable (fxarithmetic-shift-right fx1 fx2)
(assert-fixnum fx1 fx2)
(unless (and (<= 0 fx2) (< fx2 (fixnum-width)))
(raise (make-assertion-violation)))
(ash fx1 (- fx2)))
- (define (fxrotate-bit-field fx1 fx2 fx3 fx4)
+ (define-inlinable (fxrotate-bit-field fx1 fx2 fx3 fx4)
(assert-fixnum fx1 fx2 fx3 fx4)
(unless (and (<= 0 fx2 fx3) (< fx3 (fixnum-width)) (< fx4 (- fx3 fx2)))
(raise (make-assertion-violation)))
(bitwise-rotate-bit-field fx1 fx2 fx3 fx4))
- (define (fxreverse-bit-field fx1 fx2 fx3)
+ (define-inlinable (fxreverse-bit-field fx1 fx2 fx3)
(assert-fixnum fx1 fx2 fx3)
(unless (and (<= 0 fx2 fx3) (< fx3 (fixnum-width)))
(raise (make-assertion-violation)))
(bitwise-reverse-bit-field fx1 fx2 fx3))
-)
+ )
