gnunet/gnu/gnunet/scheduler.scm

;;;; -*- 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)))))