[bug#50456] Optimise bytevector->nix-base32-string and bytevector->base16-string.

[Maxime Devos <maximedevos@telenet.be>]

[-- Attachment #1.1: Type: text/plain, Size: 838 bytes --]

Hi,

Here are the test results using (ice-9 time) with
the attached "time.scm" and guix/base16.scm,
to be run with ‘make && ./pre-inst-env guix repl time.scm’:

old:
clock utime stime cutime cstime gctime
 3.93  6.32  0.03   0.00   0.00   3.59
clock utime stime cutime cstime gctime
 3.92  6.32  0.03   0.00   0.00   3.59
clock utime stime cutime cstime gctime
 3.86  6.24  0.02   0.00   0.00   3.54
new:
clock utime stime cutime cstime gctime
 2.43  3.60  0.02   0.00   0.00   1.76
clock utime stime cutime cstime gctime
 2.49  3.67  0.01   0.00   0.00   1.77
clock utime stime cutime cstime gctime
 2.64  3.77  0.01   0.00   0.00   1.77

About half as much time is spent in GC.
The ‘utime’ is also half as much.  Not sure
what ‘clock’ means exactly, but it is reduced
as well.

Greetings,
Maxime

[-- Attachment #1.2: time.scm --]
[-- Type: text/x-scheme, Size: 914 bytes --]

(define bv #vu8(95 120 195 50 116 227 63 169 222 86 89 38 92 145 126 37 192 55 34))
(define (the-test p)
  (let loop ((n 0))
    (when (< n #e1e6)
      (p bv)
      (loop (+ n 1)))))

(display "old:\n")
;; Warm up the JIT
(the-test (@ (guix base16) bytevector->base16-string/old))
;; And time the procedure
((@ (ice-9 time) time) (the-test (@ (guix base16) bytevector->base16-string/old)))
((@ (ice-9 time) time) (the-test (@ (guix base16) bytevector->base16-string/old)))
((@ (ice-9 time) time) (the-test (@ (guix base16) bytevector->base16-string/old)))

(display "new:\n")
;; Warm up the JIT
(the-test (@ (guix base16) bytevector->base16-string))
;; And time the procedure
((@ (ice-9 time) time) (the-test (@ (guix base16) bytevector->base16-string)))
((@ (ice-9 time) time) (the-test (@ (guix base16) bytevector->base16-string)))
((@ (ice-9 time) time) (the-test (@ (guix base16) bytevector->base16-string)))

[-- Attachment #1.3: base16.scm --]
[-- Type: text/x-scheme, Size: 4272 bytes --]

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2014, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix base16)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-60)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 vlist)
  #:use-module (ice-9 format)
  #:export (bytevector->base16-string
            bytevector->base16-string/old
            base16-string->bytevector))
\f
;;;
;;; Base 16.
;;;

(define (bytevector->base16-string/old bv)
  "Return the hexadecimal representation of BV's contents."
  (define len
    (bytevector-length bv))

  (let-syntax ((base16-chars (lambda (s)
                               (syntax-case s ()
                                (_
                                  (let ((v (list->vector
                                            (unfold (cut > <> 255)
                                                    (lambda (n)
                                                      (format #f "~2,'0x" n))
                                                    1+
                                                    0))))
                                    v))))))
    (define chars base16-chars)
    (let loop ((i len)
               (r '()))
      (if (zero? i)
          (string-concatenate r)
          (let ((i (- i 1)))
            (loop i
                  (cons (vector-ref chars (bytevector-u8-ref bv i)) r)))))))

(define (bytevector->base16-string bv)
  "Return the hexadecimal representation of BV's contents."
  (define len (bytevector-length bv))
  (define utf8 (make-bytevector (* len 2)))
  (let-syntax ((base16-octet-pairs
                (lambda (s)
                  (syntax-case s ()
                    (_
                     (string->utf8
                      (string-concatenate
                       (unfold (cut > <> 255)
                               (lambda (n)
                                 (format #f "~2,'0x" n))
                               1+
                               0))))))))
    (define octet-pairs base16-octet-pairs)
    (let loop ((i 0))
      (when (< i len)
        (bytevector-u16-native-set!
         utf8 (* 2 i)
         (bytevector-u16-native-ref octet-pairs
                                    (* 2 (bytevector-u8-ref bv i))))
        (loop (+ i 1))))
    (utf8->string utf8)))

(define base16-string->bytevector
  (let ((chars->value (fold (lambda (i r)
                              (vhash-consv (string-ref (number->string i 16)
                                                       0)
                                           i r))
                            vlist-null
                            (iota 16))))
    (lambda (s)
      "Return the bytevector whose hexadecimal representation is string S."
      (define bv
        (make-bytevector (quotient (string-length s) 2) 0))

      (string-fold (lambda (chr i)
                     (let ((j (quotient i 2))
                           (v (and=> (vhash-assv chr chars->value) cdr)))
                       (if v
                           (if (zero? (logand i 1))
                               (bytevector-u8-set! bv j
                                                   (arithmetic-shift v 4))
                               (let ((w (bytevector-u8-ref bv j)))
                                 (bytevector-u8-set! bv j (logior v w))))
                           (error "invalid hexadecimal character" chr)))
                     (+ i 1))
                   0
                   s)
      bv)))


[-- Attachment #2: This is a digitally signed message part --]
[-- Type: application/pgp-signature, Size: 260 bytes --]