[trivial-timeout-devel] SBCL: throw to nonexistent tag

[dat]

With sbcl 1.0.21, the SBCL timer object seems to still exists after code execution completes if the time for execution of the code body is small. This results in throw being called to a catch tag which has vanished into the mists if execution time of the body is short...

* (trivial-timeout:with-timeout (3) (foofoo))
...
"foofoo" 
NIL
*
[after a few seconds...]
 
debugger invoked on a SB-INT:SIMPLE-CONTROL-ERROR:
  attempt to THROW to a tag that does not exist: #:|label-617|


Keeping track of the timer object and unscheduling it seems to take care of things. A corresponding patch:

--- trivial-timeout/dev/with-timeout.lisp    2008-11-07 15:59:19.000000000 -0800
+++ trivial-timeout-dat/dev/with-timeout.lisp    2008-11-07 15:59:45.000000000 -0800
@@ -43,17 +43,22 @@
 (defun generate-platform-specific-code (seconds-symbol doit-symbol)
   (let ((glabel (gensym "label-"))
     (gused-timer? (gensym "used-timer-")))
-    `(let ((,gused-timer? nil))
+    `(let* ((,gused-timer? nil)
+        (gtimer 
+         (sb-ext:make-timer (lambda ()
+                  (setf ,gused-timer? t)
+                  (throw ',glabel nil))))
+        )
        (catch ',glabel
      (sb-ext:schedule-timer
-      (sb-ext:make-timer (lambda ()
-                   (setf ,gused-timer? t)
-                   (throw ',glabel nil)))
+      gtimer
       ,seconds-symbol)
-     (,doit-symbol))
+     (,doit-symbol)
+     (sb-ext:unschedule-timer gtimer)) ; nice cleanup for SBCL
        (when ,gused-timer?
      (error 'timeout-error)))))
 
+
 #+(and sbcl sb-thread)
 (defun generate-platform-specific-code (seconds-symbol doit-symbol)
   `(handler-case