[MLton-commit] r5107

[Vesa Karvonen]

More robust timer handling.

----------------------------------------------------------------------

U   mlton/trunk/ide/emacs/bg-job.el

----------------------------------------------------------------------

Modified: mlton/trunk/ide/emacs/bg-job.el
===================================================================
--- mlton/trunk/ide/emacs/bg-job.el	2007-02-01 16:43:55 UTC (rev 5106)
+++ mlton/trunk/ide/emacs/bg-job.el	2007-02-01 17:15:36 UTC (rev 5107)
@@ -33,8 +33,7 @@
 A job may call `bg-job-start' to start new jobs and multiple background
 jobs may be active simultaneously."
   (push (cons args (cons done? (cons step finalize))) bg-job-queue)
-  (unless (cdr bg-job-queue)
-    (bg-job-reschedule)))
+  (bg-job-reschedule))
 
 (defun bg-job-done? (job)
   (apply (cadr job) (car job)))
@@ -46,16 +45,18 @@
   (apply (cdddr job) (car job)))
 
 (defvar bg-job-queue nil)
+(defvar bg-job-timer nil)
 
 (defconst bg-job-period 0.03)
 (defconst bg-job-cpu-ratio 0.3)
 
 (defun bg-job-reschedule ()
-  (when bg-job-queue
-    (run-with-timer
-     (/ bg-job-period bg-job-cpu-ratio)
-     nil
-     (function bg-job-quantum))))
+  (unless bg-job-timer
+    (setq bg-job-timer
+          (run-with-timer
+           (/ bg-job-period bg-job-cpu-ratio)
+           nil
+           (function bg-job-quantum)))))
 
 (defun bg-job-quantum ()
   (let ((start-time (bg-job-time-to-double (current-time))))
@@ -67,7 +68,9 @@
             (bg-job-finalize job)
           (bg-job-step job)
           (setq bg-job-queue (nconc bg-job-queue (list job)))))))
-  (bg-job-reschedule))
+  (setq bg-job-timer nil)
+  (when bg-job-queue
+    (bg-job-reschedule)))
 
 (defun bg-job-time-to-double (time)
   (+ (* (car time) 65536.0)