Add fibers-delay/eager

knots/promise.scm

@@ -28,6 +28,7 @@
   #:export (fibers-promise?
 
             fibers-delay
+            fibers-delay/eager
             fibers-force
             fibers-promise-reset
             fibers-promise-result-available?))
@@ -105,6 +106,20 @@
            (raise-exception res)
            (apply values res))))))
 
+
+(define (fibers-delay/eager thunk)
+  (let ((promise (fibers-delay thunk)))
+    (spawn-fiber
+     (lambda ()
+       (with-exception-handler
+           (lambda _
+             ;; Silently handle this exception
+             #f)
+         (lambda ()
+           (fibers-force promise))
+         #:unwind? #t)))
+    promise))
+
 (define (fibers-promise-reset fp)
   (atomic-box-set! (fibers-promise-values-box fp)
                    #f))

knots/sort.scm

@@ -0,0 +1,88 @@
+;;; Guile Knots
+;;; Copyright © 2020, 2025 Christopher Baines <mail@cbaines.net>
+;;;
+;;; This file is part of Guile Knots.
+;;;
+;;; The Guile Knots 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.
+;;;
+;;; The Guile Knots 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 the guix-data-service.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (knots sort)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-71)
+  #:use-module (ice-9 match)
+  #:use-module (fibers scheduler)
+  #:use-module (knots promise)
+  #:export (fibers-sort!))
+
+(define (try-split-at! lst i)
+  (cond ((< i 0)
+         (error "negitive split size"))
+        ((= i 0)
+         (values '() lst))
+        (else
+         (let lp ((l lst) (n (- i 1)))
+           (if (<= n 0)
+               (let ((tmp (cdr l)))
+                 (unless (null? tmp)
+                   (set-cdr! l '()))
+                 (values lst tmp))
+               (if (or (null? l)
+                       (null? (cdr l)))
+                   (values lst '())
+                   (lp (cdr l) (- n 1))))))))
+
+(define (chunk! lst max-length)
+  (let loop ((chunks '())
+             (lst lst))
+    (let ((chunk
+           rest
+           (try-split-at! lst max-length)))
+      (if (null? rest)
+          (reverse! (cons chunk chunks))
+          (loop (cons chunk chunks)
+                rest)))))
+
+(define* (fibers-sort! items less #:key parallelism)
+  (define requested-chunk-count
+    (or parallelism
+        (+ 1 (length (scheduler-remote-peers (current-scheduler))))))
+
+  (define items-length (length items))
+
+  (if (= 0 items-length)
+      items
+      (let* ((chunk-length (ceiling (/ items-length
+                                       requested-chunk-count)))
+             (chunks (chunk! items chunk-length)))
+        (let loop ((sorted-chunk-promises
+                    (map
+                     (lambda (chunk)
+                       (fibers-delay/eager
+                        (lambda ()
+                          (sort! chunk less))))
+                     chunks)))
+          (if (null? (cdr sorted-chunk-promises))
+              (fibers-force
+               (first sorted-chunk-promises))
+              (loop
+               (map
+                (match-lambda
+                  ((items) items)
+                  ((a b)
+                   (fibers-delay/eager
+                    (lambda ()
+                      (merge! (fibers-force a)
+                              (fibers-force b)
+                              less)))))
+                (chunk! sorted-chunk-promises 2))))))))

tests/sort.scm

@@ -0,0 +1,28 @@
+(use-modules (tests)
+             (fibers)
+             (unit-test)
+             (knots sort))
+
+(run-fibers-for-tests
+ (lambda ()
+   (assert-equal
+    '()
+    (fibers-sort! '() <))
+
+   (assert-equal
+    '(1)
+    (fibers-sort! (list 1) <))
+
+   (assert-equal
+    '(1)
+    (fibers-sort! (list 1) < #:parallelism 10))
+
+   (assert-equal
+    '(1 2)
+    (fibers-sort! (list 2 1) <))
+
+   (assert-equal
+    (sort (reverse! (iota 100)) <)
+    (fibers-sort! (reverse! (iota 100)) < #:parallelism 10))))
+
+(display "sort test finished successfully\n")