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")