diff --git a/knots/promise.scm b/knots/promise.scm index 6aa3f0b..c01d219 100644 --- a/knots/promise.scm +++ b/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)) diff --git a/knots/sort.scm b/knots/sort.scm new file mode 100644 index 0000000..dcad052 --- /dev/null +++ b/knots/sort.scm @@ -0,0 +1,88 @@ +;;; Guile Knots +;;; Copyright © 2020, 2025 Christopher Baines +;;; +;;; 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 +;;; . + +(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)))))))) diff --git a/tests/sort.scm b/tests/sort.scm new file mode 100644 index 0000000..a80b84b --- /dev/null +++ b/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")