Re: SHA256 performance with Guile 2.2 vs. Guile 3.0

[Ludovic Courtès]

Ludovic Courtès <address@hidden> 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))
 
-)
+  )