bug#72095: Non-local exit with thunk from system-async-mark doesn't restore asyncs block level

Andrew Tropin via "Bug reports for GUILE, GNU's Ubiquitous Extension Language" <[email protected]> Sat, 13 Jul 2024 20:16:21 +0400
Newsgroups	gmane.lisp.guile.bugs
Message-ID	<[email protected]>
TLDR:
abort-to-prompt restores asyncs block level.
abort-to-prompt from a procedure scheduled with system-async-mark
doesn't restore asyncs block level.


Some more context:

I was trying to implement interruptible and reusable threads on top of
delimited continuations and asynchronous interrupts.

The interruption of evaluation is implemented simply by aborting to
prompt by procedure scheduled with system-async-mark.  It works fine.

The problem is that there is a short moment of time when we are outside
of prompt and if someone will try to abort to prompt it will fail.  To
prevent this, the prompt setup routine is done in the context, where
asyncs are blocked, after prompt is set we can run a thunk in context
with unblocked asyncs (so it can be interrupted).

So this was a plan, but unfortunatelly if abort-to-prompt is done by a
procedure scheduled by system-async-mark the asyncs are not re-blocked
and thus next attempt to unblock asyncs fails with exception.

I have an idea on how to workaround my use case, but it seems that
non-local escape in procedures scheduled by system-async-mark doesn't
re-block asyncs is potentially a bug.  Here is a simplified reproducer
of the problem:

--8<---------------cut here---------------start------------->8---
(begin
  (use-modules (ice-9 threads))

  (define prompt-tag (make-prompt-tag 'tmp))

  (define (blocked-async-loop)
    (call-with-blocked-asyncs
     (lambda ()
       (let loop ((i 0))

         (format #t "\nstep: ~a\n" i)
         (format #t "--->\n")

         (call-with-prompt
          prompt-tag
          (lambda ()
            (format #t "++++ inside prompt\n" i)
            (call-with-unblocked-asyncs
             (lambda ()
               (format #t "++++ inside unblocked async\n" i)
               ;; This jump works fine.  Async get re-blocked
               (abort-to-prompt prompt-tag 'from-inside-loop))))
           (lambda (k . args)
             (format #t "==== jumped out of prompt: ~a\n" args)))

         (format #t "<---\n")

         (sleep 2)
         (when (< i 5)
           (loop (1+ i)))))))

  (let* ((th (call-with-new-thread (lambda () (blocked-async-loop)))))
    (sleep 3)
    (system-async-mark
     (lambda ()
       ;; This jump doesn't lead to re-blocking asyncs
       (abort-to-prompt prompt-tag 'from-async-mark))
     th)

    (sleep 8)))
--8<---------------cut here---------------end--------------->8---

The output is following:
--8<---------------cut here---------------start------------->8---
step: 0
--->
++++ inside prompt
++++ inside unblocked async
==== jumped out of prompt: (from-inside-loop)
<---

step: 1
--->
++++ inside prompt
++++ inside unblocked async
==== jumped out of prompt: (from-inside-loop)
<---

step: 2
--->
++++ inside prompt
==== jumped out of prompt: (from-async-mark)
<---

step: 3
--->
++++ inside prompt
           3 (call-with-blocked-asyncs #<procedure 7f54c4fdf288 at /…>)
In /data/abcdw/work/abcdw/guile-ares-rs/dev/guile/2024-07-13-async-mark-block.scm:
    18:12  2 (_)
In unknown file:
           1 (call-with-unblocked-asyncs #<procedure 7f54c5ec9ae0 at…>)
In ice-9/boot-9.scm:
  1676:22  0 (raise-exception _ #:continuable? _)
ice-9/boot-9.scm:1676:22: In procedure raise-exception:
In procedure call-with-unblocked-asyncs: asyncs already unblocked
--8<---------------cut here---------------end--------------->8---

Similiar report:
https://debbugs.gnu.org/cgi/bugreport.cgi?bug=48566

-- 
Best regards,
Andrew Tropin
signature.asc (application/pgp-signature, 832 B)