From dathomp1 at yahoo.com  Sat Nov  8 00:08:55 2008
From: dathomp1 at yahoo.com (dat)
Date: Fri, 7 Nov 2008 16:08:55 -0800 (PST)
Subject: [trivial-timeout-devel] SBCL: throw to nonexistent tag
Message-ID: <429086.24417.qm@web50002.mail.re2.yahoo.com>

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 


      



From gwking at metabang.com  Sat Nov  8 16:54:30 2008
From: gwking at metabang.com (Gary King)
Date: Sat, 8 Nov 2008 11:54:30 -0500
Subject: [trivial-timeout-devel] SBCL: throw to nonexistent tag
In-Reply-To: <429086.24417.qm@web50002.mail.re2.yahoo.com>
References: <429086.24417.qm@web50002.mail.re2.yahoo.com>
Message-ID: <21CBE263-3B2B-4399-8CD9-B0BAE1E7AF56@metabang.com>

Hi Thanks for the patch. I'll add a test case and try to get this out  
this weekend.


On Nov 7, 2008, at 7:08 PM, dat wrote:

> 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
>
>
>
>
> _______________________________________________
> trivial-timeout-devel mailing list
> trivial-timeout-devel at common-lisp.net
> http://common-lisp.net/cgi-bin/mailman/listinfo/trivial-timeout-devel

--
Gary Warren King, metabang.com
Cell: (413) 559 8738
Fax: (206) 338-4052
gwkkwg on Skype * garethsan on AIM