176 lines
6.7 KiB
Scheme
176 lines
6.7 KiB
Scheme
;;;; -*- mode: Scheme; indent-tabs-mode: nil; fill-column: 80; -*-
|
||
;;;;
|
||
;;;; Copyright © 2015 Rémi Delrue <asgeir@free.fr>
|
||
;;;;
|
||
;;;; This program 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.
|
||
;;;;
|
||
;;;; This program 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 this program. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
(define-module (gnu gnunet scheduler)
|
||
#:use-module (srfi srfi-1)
|
||
#:use-module (ice-9 match)
|
||
#:use-module (system foreign)
|
||
#:use-module (gnu gnunet binding-utils)
|
||
#:use-module (gnu gnunet common)
|
||
#:use-module (gnu gnunet configuration)
|
||
#:export (default-error-handler
|
||
call-with-scheduler
|
||
add-task!
|
||
#; set-next-task!
|
||
cancel-task!
|
||
schedule-shutdown!))
|
||
|
||
|
||
(define-gnunet %scheduler-run
|
||
"GNUNET_SCHEDULER_run" : '(* *) -> void)
|
||
(define-gnunet schedule-shutdown!
|
||
"GNUNET_SCHEDULER_shutdown" : '() -> void)
|
||
|
||
#;(define-gnunet %add-continuation
|
||
"GNUNET_SCHEDULER_add_continuation" : (list '* '* unsigned-int) -> void)
|
||
#;(define-gnunet %add-continuation-with-priority
|
||
"GNUNET_SCHEDULER_add_continuation_with_priority" :
|
||
(list '* '* unsigned-int unsigned-int) -> void)
|
||
|
||
(define-gnunet %add-with-priority
|
||
"GNUNET_SCHEDULER_add_with_priority" : (list unsigned-int '* '*) -> '*)
|
||
|
||
(define-gnunet %add-now
|
||
"GNUNET_SCHEDULER_add_now" : '(* *) -> '*)
|
||
|
||
(define-gnunet %add-delayed
|
||
"GNUNET_SCHEDULER_add_delayed" : (list time-relative '* '*) -> '*)
|
||
(define-gnunet %add-delayed-with-priority
|
||
"GNUNET_SCHEDULER_add_delayed_with_priority" :
|
||
(list time-relative unsigned-int '* '*) -> '*)
|
||
|
||
(define-gnunet cancel-task! "GNUNET_SCHEDULER_cancel" : '(*) -> '*)
|
||
|
||
(define-gnunet %speedup-start "GNUNET_SPEEDUP_start_" : '(*) -> int)
|
||
(define-gnunet %speedup-stop "GNUNET_SPEEDUP_stop_" : '() -> void)
|
||
|
||
(define-gnunet %resolver-connect "GNUNET_RESOLVER_connect" : '(*) -> void)
|
||
|
||
|
||
(define priorities-alist
|
||
'((#:keep . 0)
|
||
(#:idle . 1)
|
||
(#:background . 2)
|
||
(#:default . 3)
|
||
(#:high . 4)
|
||
(#:ui . 5)
|
||
(#:urgent . 6)
|
||
(#:shutdown . 7)
|
||
(#:count . 8)))
|
||
|
||
(define (priority->number priority)
|
||
(assq-ref priorities-alist priority))
|
||
|
||
(define (number->priority n)
|
||
(rassq-ref priorities-alist n))
|
||
|
||
(define reasons-alist
|
||
'((#:none . 0)
|
||
(#:startup . 1)
|
||
(#:shutdown . 2)
|
||
(#:timeout . 4)
|
||
(#:read-ready . 8)
|
||
(#:write-ready . 16)
|
||
(#:prerequisite-done . 32)))
|
||
|
||
(define (reason-list->number . reasons)
|
||
(define (reason->number r)
|
||
(or (assq-ref reasons-alist r)
|
||
(throw 'invalid-arg "reason->number" r)))
|
||
(fold (lambda (reason result)
|
||
(logand (reason->number reason) result))
|
||
0 reasons))
|
||
|
||
(define (number->reason-list n)
|
||
(fold (lambda (reason result)
|
||
(if (zero? (logand (cdr reason) n))
|
||
result
|
||
(cons (car reason) result)))
|
||
'() reasons-alist))
|
||
|
||
|
||
(define (task-thunk->pointer thunk error-handler)
|
||
"Wraps THUNK for use with the scheduler, and returns a pointer to it.
|
||
THUNK should be a function of one argument: a list of reasons (as keywords)."
|
||
(procedure->pointer void
|
||
(lambda (unused %context)
|
||
(match (parse-c-struct %context
|
||
(list unsigned-int '* '*))
|
||
((%reasons _ _)
|
||
;; (with-throw-handler
|
||
;; #t (thunk (number->reason-list %reasons))
|
||
;; (lambda args (backtrace)))
|
||
; (catch #t
|
||
(thunk (number->reason-list %reasons)))))
|
||
; error-handler))))
|
||
'(* *)))
|
||
|
||
(define (default-error-handler key . args)
|
||
(simple-format #t "GNUNET SHUTDOWN: ~s ~s\n" key args)
|
||
(schedule-shutdown!))
|
||
|
||
(define* (call-with-scheduler config thunk
|
||
#:key (error-handler default-error-handler))
|
||
"Initialize and run GnuNet’s scheduler, that will start by calling THUNK, and
|
||
will only return when all tasks have been completed.
|
||
|
||
On systems with signals, receiving a SIGTERM (or any other similar signal)
|
||
causes `scheduler-shutdown` to be run after the active task is completed. As a
|
||
result, SIGTERM causes all the current pending tasks to be marked as ready, and
|
||
scheduled for immediate execution with reason #:shutdown. However, tasks
|
||
scheduled *after* the call to `scheduler-shutdown` may still be delayed
|
||
arbitrarily."
|
||
(define (init-and-start reasons)
|
||
(when (not (member #:shutdown reasons))
|
||
(%speedup-start (unwrap-configuration config))
|
||
(%resolver-connect (unwrap-configuration config))
|
||
(thunk reasons)))
|
||
(%scheduler-run (task-thunk->pointer init-and-start error-handler)
|
||
%null-pointer))
|
||
|
||
;;+TODO: shall I (assert (uint64? delay)) ?
|
||
;;+TODO: map delay = inf to %delay = uint64_max
|
||
(define* (add-task! thunk #:key (delay 0) (priority #:default)
|
||
(error-handler default-error-handler))
|
||
"Schedule THUNK for execution with DELAY with PRIORITY.
|
||
|
||
– DELAY is an integer in microseconds,
|
||
– PRIORITY is a keyword."
|
||
(let ((%thunk (task-thunk->pointer thunk error-handler)))
|
||
;; in the following calls to the %add-* functions, %null-pointer designates
|
||
;; the “closure” of the task (a simulation of the closure concept in C). As
|
||
;; we have real closures, we don’t need to use this, hence the null pointer.
|
||
(cond ((and (zero? delay) (eq? #:default priority))
|
||
(%add-now %thunk %null-pointer))
|
||
((zero? delay)
|
||
(%add-with-priority (priority->number priority) %thunk %null-pointer))
|
||
((eq? #:default priority)
|
||
(%add-delayed delay %thunk %null-pointer))
|
||
(else
|
||
(%add-delayed-with-priority delay (priority->number priority)
|
||
%thunk %null-pointer)))))
|
||
|
||
#;(define* (set-next-task! thunk #:key (reasons '(#:none)) (priority #:default)
|
||
(error-handler default-error-handler))
|
||
"Schedule TASK as the next action to complete."
|
||
(let ((%thunk (task-thunk->pointer thunk error-handler))
|
||
(%reasons (apply reason-list->number reasons)))
|
||
(if (eq? priority #:default)
|
||
(%add-continuation %thunk %null-pointer %reasons)
|
||
(%add-continuation-with-priority %thunk %null-pointer %reasons
|
||
(priority->number priority)))))
|