guix
/
guix-cuirass
mirror of git://git.savannah.gnu.org/guix/guix-cuirass.git
2
0
Fork 0
Code Issues Releases Wiki Activity

utils: Do not block the calling fiber. 

Setting current-fiber to #f in %non-blocking will prevent put-message in the
new thread to try suspending itself, but will also cause the same behavior on
get-message, which is not desired.

* src/cuirass/utils.scm (%non-blocking): Reduce the scope of current-fiber
parameter to the newly created thread.
This commit is contained in:
Mathieu Othacehe 2020-07-29 19:08:04 +02:00
parent e41327350d
commit 6ad9c60269
No known key found for this signature in database
GPG Key ID: 8354763531769CA6
1 changed files with 10 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
src/cuirass/utils.scm
View File

@ -144,23 +144,23 @@ VARS... are bound to the arguments of the worker thread."
(lambda (vars ...) exp ...)))
(define (%non-blocking thunk)
(parameterize (((@@ (fibers internal) current-fiber) #f))
(let ((channel (make-channel)))
(call-with-new-thread
(lambda ()
(let ((channel (make-channel)))
(call-with-new-thread
(lambda ()
(parameterize (((@@ (fibers internal) current-fiber) #f))
(catch #t
(lambda ()
(call-with-values thunk
(lambda values
(put-message channel `(values ,@values)))))
(lambda args
(put-message channel `(exception ,@args))))))
(put-message channel `(exception ,@args)))))))
(match (get-message channel)
(('values . results)
(apply values results))
(('exception . args)
(apply throw args))))))
(match (get-message channel)
(('values . results)
(apply values results))
(('exception . args)
(apply throw args)))))
(define-syntax-rule (non-blocking exp ...)
"Evalaute EXP... in a separate thread so that it doesn't block the execution