ide/emacs/bg-job.el

   1 ;; Copyright (C) 2007 Vesa Karvonen
   2 ;;
   3 ;; MLton is released under a BSD-style license.
   4 ;; See the file MLton-LICENSE for details.
   5
   6 (require 'cl)
   7 (require 'compat)
   8
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10 ;; Customization
  11
  12 (defgroup bg-job nil
  13   "The background job module allows emacs to perform time consuming
  14 processing jobs in the background while allowing the user to continue
  15 editing.  See the documentation of the `bg-job-start' function for
  16 details.")
  17
  18 (defcustom bg-job-period 0.10
  19   "Timer period in seconds for background processing interrupts.  Must
  20 be positive."
  21   :type 'number
  22   :group 'bg-job)
  23
  24 (defcustom bg-job-cpu-ratio 0.15
  25   "Ratio of CPU time allowed for background processing.  Must be positive
  26 and less than 1."
  27   :type 'number
  28   :group 'bg-job)
  29
  30 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  31 ;; Background Processor
  32
  33 (defun bg-job-start (done? step finalize &rest args)
  34   "Starts a background job.  The job is considered active as longs as
  35
  36   (apply done? args)
  37
  38 returns nil.  While the job is active,
  39
  40   (apply step args)
  41
  42 will be called periodically to perform a (supposedly small) computation
  43 step.  After the job becomes inactive,
  44
  45   (apply finalize args)
  46
  47 will be called once and the job will be discarded.
  48
  49 A job may call `bg-job-start' to start new jobs and multiple background
  50 jobs may be active simultaneously."
  51   (let ((job (cons args (cons done? (cons step finalize)))))
  52     (push job bg-job-queue))
  53   (bg-job-timer-start))
  54
  55 (defun bg-job-done? (job)
  56   (apply (cadr job) (car job)))
  57
  58 (defun bg-job-step (job)
  59   (apply (caddr job) (car job)))
  60
  61 (defun bg-job-finalize (job)
  62   (apply (cdddr job) (car job)))
  63
  64 (defvar bg-job-queue nil)
  65 (defvar bg-job-timer nil)
  66
  67 (defun bg-job-timer-start ()
  68   (unless bg-job-timer
  69     (setq bg-job-timer
  70           (run-with-timer
  71            bg-job-period bg-job-period (function bg-job-quantum)))))
  72
  73 (defun bg-job-timer-stop ()
  74   (when bg-job-timer
  75     (compat-delete-timer bg-job-timer)
  76     (setq bg-job-timer nil)))
  77
  78 (defun bg-job-quantum ()
  79   (let ((end-time (+ (bg-job-time-to-double (current-time))
  80                      (* bg-job-period bg-job-cpu-ratio))))
  81     (while (and (< (bg-job-time-to-double (current-time))
  82                    end-time)
  83                 bg-job-queue)
  84       (let ((job (pop bg-job-queue)))
  85         (if (bg-job-done? job)
  86             (bg-job-finalize job)
  87           (bg-job-step job)
  88           (setq bg-job-queue (nconc bg-job-queue (list job)))))))
  89   (unless bg-job-queue
  90     (bg-job-timer-stop)))
  91
  92 (defun bg-job-time-to-double (time)
  93   (+ (* (car time) 65536.0)
  94      (cadr time)
  95      (* (caddr time) 1e-06)))
  96
  97 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  98
  99 (provide 'bg-job)