[Gcl-devel] Re: with-timeout - a sketch?

[Camm Maguire]

Greetings!

This stuff is quite interesting and ingenious!  Just thought I'd
mention a few things -- select in libc does something similar, and as
I've mentioned in the previous post we have a beginning hook now into
lisp.  CMUCL uses this for job multiplexing to my limited
understanding -- I believe all within one process.  select likely uses
some signalling mechanism internal to its definition, though I have no
knowledge of the particulars.  The older way to do i/o multiplexing
was by sending SIGIO.  In this case, one must take care that certain
system calls remain restartable across a signal.  On an earlier
project, I found out that one such call which could permanently fail
across signals regardless of file descriptor settings was read!
Finally, gcl-tk uses SIGUSR1 to communicate with gcltksrv, and the
windows port kills itself with sigalrm (apparently).  I like signals
in general, but there are certain portability problems, as well as
code protection issues.  You will see BEGIN_NO_INTERRUPT
etc. throughout the C code -- this blocks interfering signals during
the critical moments.  I've avoided building atop this structure, as I
have not verified for myself precisely what the minimal set of calls
needing protection is.  This aspect of GCL could use an overhaul.

Take care,


Robert Boyer <address@hidden> writes:

> ; Here is a sketch of an implementation of with-timeout.  It would be
> ; better if GCL had a function like get-universal-time that worked in
> ; microseconds and Linux had a sleep command that worked in
> ; microseconds.
> 
> ; We steal signal 2 so that it is no longer useful for GCL user
> ; interrupts to the console.  We should use some other signal number
> ; but don't know how.
> 
> ; The *waiting-stack* is a list of (i . time) pairs, where the i is an
> ; integer catch tag and time is a universal time.  In a good
> ; implementation, the tags would somehow have to be eq different from
> ; any tags the user might create, but we use simple integers here.
> (defvar *waiting-stack* nil)
> 
> ; *setting-up-timeout* is just a hack to indicate where a critical
> ; section is needed, but we'll never understand these things.
> (defvar *setting-up-timeout* nil)
> 
> (defmacro with-timeout (seconds &rest forms)
>   ;; If seconds pass before the evaluation of forms is complete, nil is 
> returned.
>   ;; Otherwise, the value of the last of forms is returned.
>   (let ((v (gensym)))
>     `(let* ((,v ,seconds)
>           (n (cond ((null *waiting-stack*) 0)
>                    (t (+ 1 (caar *waiting-stack*)))))
>           (w (cons (cons n (+ (get-universal-time) ,v))
>                    *waiting-stack*)))
>        (cond ((or *trying-to-stop* *setting-up-timeout*)
>             (error "Think harder!")))
>        (let* ((*setting-up-timeout* t)
>             (*waiting-stack* w))
>        ;; For an instant, *waiting-stack* has an entry on it that we better 
> not go to.
>        (catch n
>          (let ((*setting-up-timeout* nil))
>            ;; but now, the catch stack and *waiting-stack* are resynchronized.
>            (si::system (format nil "interrupt ~a ~a &" ,v (si::getpid)))
>            ,@forms))))))
>   
> ; *trying-to-stop* is just a hack to indicate where a critical section
> ; is needed, but we'll never understand these things.
> (defvar *trying-to-stop* nil)
> 
> (defun si::terminal-interrupt (correctablep)
>   (declare (ignore correctablep))
>   (cond ((or *trying-to-stop* *setting-up-timeout*)
>        (error "Think harder!")))
>   (let ((*trying-to-stop* t))
>     (let ((time (get-universal-time))
>         (destination nil))
>       (loop for x in *waiting-stack*
>           when (>= time (cdr x))
>           do (setq destination (car x)))
>       (cond (destination
>            (throw destination 'nil))))))
> 
> #|  Here is the file /u/boyer/bin/interrupt
> 
> sleep $1
> /bin/kill -2 $2
> 
> |#
> 
> ; Under this design, the user might create timer interrupts that may
> ; stay around for a long time after they are relevant to any body.  So
> ; perhaps a list of the process id's of timer interrupt processes
> ; created should be kept and occasionally cleansed by the top-level
> ; loop.
> 
> -------------------------------------------------------------------------------
> 
> 
> % g
> GCL (GNU Common Lisp)  2.7.0 ANSI    Oct 29 2005 16:46:15
> Source License: LGPL(gcl,gmp), GPL(unexec,bfd)
> Binary License:  GPL due to GPL'ed components: (BFD UNEXEC)
> Modifications of this banner must retain notice of a compatible license
> Dedicated to the memory of W. Schelter
> 
> Use (help) to get some basic information on how to use GCL.
> 
> >(load "foo.lisp")
> 
> Loading foo.lisp
> Finished loading foo.lisp
> T
> 
> >(time (with-timeout 1 (with-timeout 4 (with-timeout 300 (loop)))))
> 
> real time       :      1.040 secs
> run-gbc time    :      0.810 secs
> child run time  :      0.010 secs
> gbc time        :      0.200 secs
> NIL
> 
> >(time (with-timeout 8 (with-timeout 4 (with-timeout 300 (loop)))))
> 
> real time       :      4.030 secs
> run-gbc time    :      3.560 secs
> child run time  :      0.000 secs
> gbc time        :      0.440 secs
> NIL
> 
> >(time (with-timeout 8 (with-timeout 4 (with-timeout 1 'win))))
> 
> real time       :      0.010 secs
> run-gbc time    :      0.000 secs
> child run time  :      0.010 secs
> gbc time        :      0.000 secs
> WIN
> 
> >
> 
> 
> 

-- 
Camm Maguire                                            address@hidden
==========================================================================
"The earth is but one country, and mankind its citizens."  --  Baha'u'llah