;;;; -*- mode: Scheme; indent-tabs-mode: nil; fill-column: 80; -*- ;;;; ;;;; Copyright © 2015 Rémi Delrue ;;;; ;;;; 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 . (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)))))