[BUG] Non-local exit in thunk from system-async-mark doesn't restore asyncs block

[Andrew Tropin]

TLDR:
abort-to-prompt restores asyncs block level.
abort-to-prompt from a procedure scheduled with system-async-mark
doesn't restort 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 'tmp)

  (define (jump-out-of-prompt-thunk . args)
    (lambda ()
      (apply abort-to-prompt prompt-tag args)))

  (define (with-unblocked-asyncs-thunk thunk)
    "Return a thunk, which runs a THUNK in context with unblocked-asyncs."
    (lambda ()
      (call-with-unblocked-asyncs
       (lambda ()
         (format #t "asyncs unblocked.\n")
         (thunk)))))

  (define (blocked-async-loop)
    (call-with-blocked-asyncs
     (lambda ()
       (let loop ((i 0))
         (newline)
         (format #t "---> going to enter the prompt\n")

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

         (format #t "<--- I'm out of prompt: ~a.\n" i)
         (sleep 2)
         (when (< i 4)
           (loop (1+ i))))
       (format #t "I'm almost finished.\n"))))

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

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

The output is following:
--8<---------------cut here---------------start------------->8---
---> going to enter the prompt
asyncs unblocked.
==== jumped out of prompt: (from-inside-loop)
<--- I'm out of prompt: 0.

---> going to enter the prompt
asyncs unblocked.
==== jumped out of prompt: (from-inside-loop)
<--- I'm out of prompt: 1.

---> going to enter the prompt
==== jumped out of prompt: (from-async-mark)
<--- I'm out of prompt: 2.

---> going to enter the prompt
           5 (call-with-blocked-asyncs #<procedure 7fcc5b0dae80 at i…>)
In ice-9/eval.scm:
    619:8  4 (_ #(#(#<directory (guile-user) 7fcc62ee7c80>)))
    619:8  3 (_ #(#(#<directory (guile-user) 7fcc62ee7c80> #<va…>) 3))
In ice-9/boot-9.scm:
    724:2  2 (call-with-prompt tmp #<procedure 7fcc5b2d6060 at ice-…> …)
In unknown file:
           1 (call-with-unblocked-asyncs #<procedure 7fcc5b2d6000 at…>)
In ice-9/boot-9.scm:
  1685:16  0 (raise-exception _ #:continuable? _)
ice-9/boot-9.scm:1685:16: In procedure raise-exception:
In procedure call-with-unblocked-asyncs: asyncs already unblocked
--8<---------------cut here---------------end--------------->8---

-- 
Best regards,
Andrew Tropin

signature.asc
Description: PGP signature