They're taking a while to run, but so far all my other tests are also
passing in mono-threaded guile 1.8.5
commit 9143131b2766d1e29e05d61b5021395b4c93a6bc Neil Jerram, July 11
Just to be clear: do you mean that they are passing _after_ this
commit, but were failing _before_? That's nice to know if so! What
are your OS and compiler version?
Hi Neil,
I mean that for every commit between this one and 1.8.0 that I've tested,
the default compile has failed the tests, and that for both 1.8.1 and this
commit (I have tested none between) compiling --without-threads makes my
tests pass.
I would surmise that this is an extremely longstanding issue that was
introduced some time before 1.8.1, and that I only noticed it now because I
was trying to use the default build. I do not assert that it has anything
at all to do with this particular commit -- I just wanted to let people
know where my newest endpoint was. Sorry to be unclear.
I'm running on a modified debian 32-bit architecture. I can't say exactly
how it's modified because my institution, not I, did the modifications.
However, I have attached again the scheme code to test this condition. I
hope it will be helpful in tracking down the issue. For my own sake, I'm
happy to use mono-threaded guile.
If you do find the threading issue, I would love it if some version of
with-timeout were to make it into the guile core. It's useful. I
apologise for letting the copyright assignment issue stall somewhere. I'll
look into it again.
Thanks,
Grem
--
------ __@ Gregory A. Marton http://csail.mit.edu/~gremio/
--- _`\<,_ .
-- (*)/ (*) Premature optimization is the root of all evil.
~~~~~~~~~~~~~~~~-~~~~~~~~_~~~_~~~~~v~~~~^^^^~~~~~--~~~~~~~~~~~~~~~++~~~~~~~
(define (ensure body-lambda ensuring-lambda)
(dynamic-wind
(lambda () #t)
body-lambda
ensuring-lambda))
(define (with-sigaction signum handler flags lamb)
(let ((old-sigaction (sigaction signum)))
(if flags (sigaction signum handler flags) (sigaction signum handler))
(ensure
lamb
(lambda ()
(sigaction signum (car old-sigaction) (cdr old-sigaction))))))
(define (with-timeout t thunk . handler)
(let ((time-left (alarm 0)) ;;time left on an outer alarm
(start-time (current-time)))
(alarm time-left) ;;continue the outer countdown
(catch 'parent-timeout-error
(lambda ()
(catch 'timeout-error
(lambda ()
(with-sigaction SIGALRM
(lambda (sig)
(if (and (< time-left t) (not (equal? time-left 0)))
(throw 'parent-timeout-error)
(throw 'timeout-error)))
#f
(lambda ()
(ensure
(lambda ()
(begin
(if (or (< t time-left) (equal? time-left 0))
(alarm t)) ;;time out in the shorter time, not the
most recently set time
(thunk)))
(lambda ()
(if (equal? time-left 0)
(alarm 0)
;;reset the outer alarm if there was one, subtracting
time taken by the thunk
(let* ((time-taken (- (current-time) start-time))
(time-remaining (- time-left time-taken)))
(alarm 0)
(if (<= 0 time-remaining) ; guile 1.3 is broken and
(alarm time-remaining) ; this can happen.
(raise SIGALRM))))))))) ;better late than never?
(lambda (k . v)
(if (null? handler)
(throw k)
((car handler))))))
(lambda (k . v)
(raise SIGALRM)))))
(define (assert-equals expected observed message)
(if (equal? expected observed)
#t
(begin
(map display (list "Expected: " expected "\nObserved: " observed
"\n" message "\n"))
#f)))
(display (version)) (newline)
(if (and
(assert-equals 7 (with-timeout 2 (lambda () (+ 2 5)))
"should not time out")
(assert-equals
'caught
(catch 'timeout-error
(lambda () (with-timeout 2 (lambda ()
(while #t "infinite monkeys"))))
(lambda (k . v) 'caught))
"should time out with default handler")
(assert-equals
"specified handler"
(with-timeout 2
(lambda () (begin (sleep 4) (display "fell asleep")))
(lambda () "specified handler"))
"should time out with specified handler")
(assert-equals
9
(with-timeout 2
(lambda ()
(let ((foo (+ 2 3)))
(with-timeout 2 (lambda () (+ foo 4))))))
"nested timeouts that should not time out")
(assert-equals
"inner timeout"
(with-timeout 5
(lambda ()
(let ((foo (+ 2 3)))
(with-timeout 2
(lambda () (sleep 10))
(lambda () "inner timeout"))))
(lambda () "outer timeout"))
"nested timeouts where the inner one should time out")
(assert-equals
"outer timeout"
(with-timeout 2
(lambda ()
(let ((foo (+ 2 3)))
(with-timeout
5
(lambda ()
(begin
(sleep 10)
(display "oh no, you fell asleep!")))
(lambda () "inner timeout"))))
(lambda () "outer timeout"))
"outer time has expired, and outer handler is used")
(assert-equals
"outer timeout"
(with-timeout 2
(lambda ()
(let ((foo (+ 2 3)))
(with-timeout 5
(lambda () (+ 8 7))
(lambda () "inner timeout"))
(sleep 10)
"oh no, you fell asleep!"))
(lambda () "outer timeout"))
(string-append "nested timeouts where the inner one should finish "
"but the outer one should still time out"))
(assert-equals
"outer timeout"
(with-timeout 2
(lambda ()
(let ((foo (+ 2 3)))
(with-timeout 2
(lambda ()
(+ 8 7))
(lambda ()
"inner timeout"))
(sleep 10)
"oh no, you fell asleep!"))
(lambda ()
"outer timeout"))
"when the times are the same, the outer handler is used")
)
(display "good!\n")
(primitive-exit 1))
