[PATCH] Make vector-map and vector-for-each in (rnrs base) fast

["Linus Björnstam" <linus.bjornstam@veryfast.biz>]

[-- Attachment #1: Type: text/plain, Size: 1209 bytes --]

Hi there!

I was spelunking through the guile source tree and found (rnrs base). The vector-map and vector-for-each in there are horribly inefficient. They are doing (list->vector (apply map PROC (map vector->list vectors))), which means it spends quite some time checking for circular references.

This fixes that. The speedup is surprisingly small, considering we pass through the elements 2 fewer times and don't chase pointers through memory trying to find cycles. Anywhere from 30 to 300% depending on how the stars are aligned on things like (vector-map + vec vec)

One potential speedup we could do is using eq? to compare numbers, but I don't know how well fixnums in guile overlap size_t, regardless of how realistic such a limitation would be. If I change the behaviour of vector-map to go back-to-front (order is unspecified in r6rs) we can easily do (eq? -1 index) as a stop condition to avoid any eventual overhead of type checking with =. (If those are not elided, which I suspect might be the case. ). I did not look at that, since I have too little computer time these days.

As an added bonus, this speeds up quicksort.scm in ecraven's benchmarks by a little.
-- 
  Linus Björnstam

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Write-a-proper-vector-map-and-vector-for-each-for-rn.patch --]
[-- Type: text/x-patch; name="0001-Write-a-proper-vector-map-and-vector-for-each-for-rn.patch", Size: 3545 bytes --]

From 6dc71eeec1b0efad9be23c6f72323cdc58caf26b Mon Sep 17 00:00:00 2001
From: Linus <bjornstam.linus@fastmail.se>
Date: Wed, 17 Feb 2021 22:28:19 +0100
Subject: [PATCH] Write a proper vector-map and vector-for-each for (rnrs base)

 * module/rnrs/base.scm (vector-map vector-for-each): Rewrite to not be slow.
---
 module/rnrs/base.scm | 80 +++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 76 insertions(+), 4 deletions(-)

diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm
index 9205016bd..cd2327e49 100644
--- a/module/rnrs/base.scm
+++ b/module/rnrs/base.scm
@@ -231,10 +231,82 @@
    (and (rational-valued? x)
         (= x (floor (real-part x)))))
 
- (define (vector-for-each proc . vecs)
-   (apply for-each (cons proc (map vector->list vecs))))
- (define (vector-map proc . vecs)
-   (list->vector (apply map (cons proc (map vector->list vecs)))))
+ ;; Auxiliary procedure for vector-map and vector-for-each
+ (define (vector-lengths who . vs)
+  (let ((lengths (map vector-length vs)))
+    (unless (apply = lengths)
+      (apply error
+             (string-append (symbol->string who)
+                            ": Vectors of uneven length.")
+             vs))
+    (car lengths)))
+
+(define vector-map
+  (case-lambda
+    "(vector-map f vec2 vec2 ...) -> vector
+
+Return a new vector of the size of the vector arguments, which
+must be of equal length. Each element at index @var{i} of the new 
+vector is mapped from the old vectors by @code{(f (vector-ref vec1 i)
+(vector-ref vec2 i) ...)}.  The dynamic order of application of 
+@var{f} is unspecified."
+    ((f v)
+     (let* ((len (vector-length v))
+            (result (make-vector len)))
+       (let loop ((i 0))
+         (unless (= i len)
+           (vector-set! result i (f (vector-ref v i)))
+           (loop (+ i 1))))
+       result))
+    ((f v1 v2)
+     (let* ((len (vector-lengths 'vector-map v1 v2))
+            (result (make-vector len)))
+       (let loop ((i 0))
+         (unless (= i len)
+           (vector-set! result
+                        i
+                        (f (vector-ref v1 i) (vector-ref v2 i)))
+           (loop (+ i 1)))
+         result)))
+    ((f v . vs)
+     (let* ((vs (cons v vs))
+            (len (apply vector-lengths 'vector-map vs))
+            (result (make-vector len)))
+       (let loop ((i 0))
+         (unless (= i len)
+           (vector-set! result
+                        i
+                        (apply f (map (lambda (v) (vector-ref v i)) vs)))
+           (loop (+ i 1))))
+       result))))
+
+(define vector-for-each
+  (case-lambda
+    "(vector-for-each f vec1 vec2 ...) -> unspecified
+
+Call @code{(f (vector-ref vec1 i) (vector-ref vec2 i) ...)} for each index
+ in the provided vectors, which have to be of equal length. The iteration
+is strictly left-to-right."
+    ((f v)
+     (let ((len (vector-length v)))
+       (let loop ((i 0))
+         (unless (= i len)
+           (f (vector-ref v i))
+           (loop (+ i 1))))))
+    ((f v1 v2)
+     (let ((len (vector-lengths 'vector-for-each v1 v2)))
+       (let loop ((i 0))
+         (unless (= i len)
+           (f (vector-ref v1 i) (vector-ref v2 i))
+           (loop (+ i 1))))))
+    ((f v . vs)
+     (let* ((vs (cons v vs))
+            (len (apply vector-lengths 'vector-for-each vs)))
+       (let loop ((i 0))
+         (unless (= i len)
+           (apply f (map (lambda (v) (vector-ref v i)) vs))
+           (loop (+ i 1))))))))
+
 
  (define-syntax define-proxy
    (syntax-rules (@)
-- 
2.25.1