io-wakeup.scm 4.1 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105
  1. ;; Fibers: cooperative, event-driven user-space threads.
  2. ;;;; Copyright (C) 2016,2021 Free Software Foundation, Inc.
  3. ;;;; Copyright (C) 2021 Maxime Devos
  4. ;;;;
  5. ;;;; This library is free software; you can redistribute it and/or
  6. ;;;; modify it under the terms of the GNU Lesser General Public
  7. ;;;; License as published by the Free Software Foundation; either
  8. ;;;; version 3 of the License, or (at your option) any later version.
  9. ;;;;
  10. ;;;; This library is distributed in the hope that it will be useful,
  11. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  13. ;;;; Lesser General Public License for more details.
  14. ;;;;
  15. ;;;; You should have received a copy of the GNU Lesser General Public
  16. ;;;; License along with this library; if not, write to the Free Software
  17. ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18. ;;;;
  19. (define-module (fibers io-wakeup)
  20. #:use-module (fibers scheduler)
  21. #:use-module (fibers operations)
  22. #:use-module (ice-9 atomic)
  23. #:use-module (ice-9 match)
  24. #:use-module (ice-9 threads)
  25. #:use-module (ice-9 ports internal)
  26. #:export (wait-until-port-readable-operation
  27. wait-until-port-writable-operation))
  28. (define *poll-sched* (make-atomic-box #f))
  29. (define (poll-sched)
  30. (or (atomic-box-ref *poll-sched*)
  31. (let ((sched (make-scheduler)))
  32. (cond
  33. ((atomic-box-compare-and-swap! *poll-sched* #f sched))
  34. (else
  35. ;; FIXME: Would be nice to clean up this thread at some point.
  36. (call-with-new-thread
  37. (lambda ()
  38. (define (finished?) #f)
  39. (run-scheduler sched finished?)))
  40. sched)))))
  41. ;; These procedure are subject to spurious wakeups.
  42. (define (readable? port)
  43. "Test if PORT is writable."
  44. (match (select (vector port) #() #() 0)
  45. ((#() #() #()) #f)
  46. ((#(_) #() #()) #t)))
  47. (define (writable? port)
  48. "Test if PORT is writable."
  49. (match (select #() (vector port) #() 0)
  50. ((#() #() #()) #f)
  51. ((#() #(_) #()) #t)))
  52. (define (wait-until-port-readable-operation port)
  53. "Make an operation that will succeed when PORT is readable."
  54. (unless (input-port? port)
  55. (error "refusing to wait forever for input on non-input port"))
  56. (make-base-operation #f
  57. (lambda ()
  58. (and (readable? port)
  59. values))
  60. (lambda (flag sched resume)
  61. (define (commit)
  62. (match (atomic-box-compare-and-swap! flag 'W 'S)
  63. ('W (resume values))
  64. ('C (commit))
  65. ('S #f)))
  66. (if sched
  67. (schedule-task-when-fd-readable
  68. sched (port-read-wait-fd port) commit)
  69. (schedule-task
  70. (poll-sched)
  71. (lambda ()
  72. (perform-operation (wait-until-port-readable-operation port))
  73. (commit)))))))
  74. (define (wait-until-port-writable-operation port)
  75. "Make an operation that will succeed when PORT is writable."
  76. (unless (output-port? port)
  77. (error "refusing to wait forever for output on non-output port"))
  78. (make-base-operation #f
  79. (lambda ()
  80. (and (writable? port)
  81. values))
  82. (lambda (flag sched resume)
  83. (define (commit)
  84. (match (atomic-box-compare-and-swap! flag 'W 'S)
  85. ('W (resume values))
  86. ('C (commit))
  87. ('S #f)))
  88. (if sched
  89. (schedule-task-when-fd-writable
  90. sched (port-write-wait-fd port) commit)
  91. (schedule-task
  92. (poll-sched)
  93. (lambda ()
  94. (perform-operation (wait-until-port-writable-operation port))
  95. (commit)))))))