From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Sat, 30 Apr 2016 00:36:55 +0000 (-0700)
Subject: glib: Add abort restart for cleanups and secondary-GC-daemons.
X-Git-Tag: mit-scheme-pucked-9.2.12~338
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3221a1b5affeeae2ed1342cb65de6ee66f4a8ebf;p=mit-scheme.git

glib: Add abort restart for cleanups and secondary-GC-daemons.
---

diff --git a/src/glib/glib-thread.scm b/src/glib/glib-thread.scm
index 4518bc531..a1a52ada0 100644
--- a/src/glib/glib-thread.scm
+++ b/src/glib/glib-thread.scm
@@ -52,6 +52,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 		    (done-tick 0)
 		    (next-secondary-tick secondary-gc-rate))
 		(let glib-thread-loop ()
+		  (if (not (eq? interrupt-mask/all
+				((ucode-primitive get-interrupt-enables 0))))
+		      (outf-error "\nglib-thread-loop: already running without-interrupts\n"))
 		  (without-interrupts
 		   (lambda ()
 		     (let ((gc-tick (car (gc-timestamp))))
@@ -64,7 +67,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 		       (if (fix:< next-secondary-tick gc-tick)
 			   (begin
 			     (%trace ";run-glib secondary-gc daemons\n")
-			     (trigger-secondary-gc-daemons!)
+			     (run-glib-daemons)
 			     (%trace ";run-glib secondary-gc daemons done\n")
 			     (set! next-secondary-tick
 				   (fix:+ gc-tick secondary-gc-rate)))))))
diff --git a/src/glib/glib.pkg b/src/glib/glib.pkg
index 1396c5cc1..e527d932c 100644
--- a/src/glib/glib.pkg
+++ b/src/glib/glib.pkg
@@ -111,7 +111,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   (export ()
 	  stop-glib-thread)
   (import (glib)
-	  run-glib-cleanups)
+	  run-glib-cleanups
+	  run-glib-daemons)
   (import (glib main)
 	  run-glib)
   (import (runtime primitive-io)
diff --git a/src/glib/glib.scm b/src/glib/glib.scm
index f363f9a15..4bdb86580 100644
--- a/src/glib/glib.scm
+++ b/src/glib/glib.scm
@@ -130,12 +130,29 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 	    (loop (cdr alist) alist)
 	    (let ((thunk (weak-cdr (car alist)))
 		  (next (cdr alist)))
-	      (thunk)
+	      (with-glib-error-handler "this GLib cleanup" thunk)
 	      (if prev
 		  (set-cdr! prev next)
 		  (set! glib-cleanups next))
 	      (loop next prev))))))
 
+(define (run-glib-daemons)
+  (with-glib-error-handler "the secondary GC daemons"
+			   trigger-secondary-gc-daemons!))
+
+(define (with-glib-error-handler what thunk)
+  (call-with-current-continuation
+   (lambda (continue)
+     ;;(with-restart name reporter effector interactor thunk)
+     (with-restart 'ABORT
+	 (string-append "Punt "what"; return to the GLib main loop.")
+	 (named-lambda (glib-abort-effector . args)
+	   (declare (ignore args))
+	   (continue unspecific))
+	 (named-lambda (glib-abort-interactor . args)
+	   (apply values args))
+       thunk))))
+
 (define (reset-glib-cleanups!)
   (set! glib-cleanups '()))