diff --git a/knots/promise.scm b/knots/promise.scm index c01d219..6aa3f0b 100644 --- a/knots/promise.scm +++ b/knots/promise.scm @@ -28,7 +28,6 @@ #:export (fibers-promise? fibers-delay - fibers-delay/eager fibers-force fibers-promise-reset fibers-promise-result-available?)) @@ -106,20 +105,6 @@ (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 deleted file mode 100644 index dcad052..0000000 --- a/knots/sort.scm +++ /dev/null @@ -1,88 +0,0 @@ -;;; 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 deleted file mode 100644 index a80b84b..0000000 --- a/tests/sort.scm +++ /dev/null @@ -1,28 +0,0 @@ -(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")