test/integration/starvation-probe-main.sgl

1;;; (starvation-probe main) — compiled probe for the server-loop drain

2;;; starving sibling socket io-waiters.

3;;;

4;;; Mechanism under test: the async scheduler services socket io-waiters ONLY

5;;; inside poll-waiters!, which scheduler-run reaches ONLY when the run-queue

6;;; is empty. The sigil-http server-loop `drain` busy-spun

7;;; `process-connections` (a native socket-select) while >=1 client was

8;;; connected; preemptive yield re-enqueues it READY, so the run-queue never

9;;; empties and sibling io-waiters (first reads on outbound IRC-style,

10;;; websocket, or IPC client sockets) starve — while timer-driven work keeps

11;;; running. This probe measures that directly, in one compiled process:

12;;;

13;;; phase 1 (control): first-read latency on a local TCP pair with the

14;;; http server idle (no clients) — expect fast.

15;;; phase 2 (starved): same measurement with ONE half-open client parked

16;;; on the http server (partial request, never

17;;; completed) so the drain loop spins — on the broken

18;;; runtime the reader's io-waiter never resumes and

19;;; the watchdog fires.

20;;;

21;;; The harness itself only depends on timers (sleep) and native socket

22;;; writes, both immune to the starvation, so it can observe it.

23;;;

24;;; phase 3 (stop): http-server-stop is called from a SIBLING task

25;;; (holding the pre-start record) with no traffic in

26;;; flight; the suspended serve loop must wake on its

27;;; bounded deadline, shut down, and http-server-start

28;;; must return promptly.

29;;;

30;;; Output (one line): control-ms=N starved-ms=M stop-ms=K (-1 = timed out)

31;;; Exit: 0 when all three are fast, 1 otherwise.

33(define-library (starvation-probe main)

34 (import (sigil core)

35 (sigil io)

36 (sigil process)

37 (sigil async)

38 (sigil socket)

39 (sigil time)

40 (sigil http server)

41 (sigil http response))

43 (export main)

45 (begin

47 (define http-port 18310)

48 (define pair-port-base 18320)

50 ;; Watchdog bound for one measurement, in ms. Generous enough for a slow

51 ;; box (the healthy latency is ~0-200ms), far below the 30s symptom.

52 (define watchdog-ms 8000)

54 ;; Measure the first-read latency of a socket io-waiter: reader goroutine

55 ;; awaits readability on the outbound half of a fresh local TCP pair; a

56 ;; timer-driven writer sends one byte 400ms later; latency = resume time

57 ;; minus send time. Returns latency in ms, or -1 if the watchdog fired.

58 (define (measure-first-read-latency pair-port)

59 (let ((listen (tcp-listen pair-port host: "127.0.0.1"))

60 ;; result slots: 0 = done?, 1 = t-resumed, 2 = t-sent

61 (result (vector #f #f #f)))

62 (let* ((out (%tcp-connect-sync "127.0.0.1" pair-port))

63 (peer (tcp-accept listen)))

64 (socket-set-non-blocking! out #t)

65 ;; reader — the path under test (socket io-waiter first read)

66 (go

67 (await-readable out)

68 (vector-set! result 1 (current-milliseconds))

69 (socket-read out)

70 (vector-set! result 0 #t))

71 ;; writer — timer-driven, immune to the starvation

72 (go

73 (sleep 0.4)

74 (vector-set! result 2 (current-milliseconds))

75 (socket-write peer "x"))

76 ;; wait for the reader or the watchdog (wall-clock based: sleeps

77 ;; can lag under starvation, so count real elapsed time)

78 (let ((t-start (current-milliseconds)))

79 (let wait ()

80 (cond

81 ((vector-ref result 0)

82 (let ((latency (- (vector-ref result 1)

83 (vector-ref result 2))))

84 (socket-close out)

85 (socket-close peer)

86 (socket-close listen)

87 latency))

88 ((> (- (current-milliseconds) t-start) watchdog-ms)

89 (socket-close out)

90 (socket-close peer)

91 (socket-close listen)

92 -1)

93 (else

94 (sleep 0.1)

95 (wait))))))))

97 (define (main)

98 ;; The http server under test. Long request timeout so the half-open

99 ;; client is never 408-reaped during the probe (reaping would end the

100 ;; drain spin and mask the starvation). The pre-start record is kept so

101 ;; phase 3 can stop the server from a sibling task (the goroutine-mode

102 ;; stop path).

103 (let ((srv (make-http-server

104 (lambda (req) (http-response/text HTTP-OK "ok"))

105 port: http-port

106 host: "127.0.0.1"

107 timeout: 600000))

108 (server-returned #f))

109 (with-async

110 (go

111 (http-server-start srv)

112 (set! server-returned #t))

113 (go

114 ;; let the server task start and park on its listen await

115 (sleep 0.3)

116

117 ;; phase 1 — control: no http clients, drain not running

118 (let ((control-ms (measure-first-read-latency pair-port-base))

119 (busy #f))

120

121 ;; phase 2 — park ONE half-open client on the http server:

122 ;; partial request (no terminating blank line) keeps it in

123 ;; http-server-clients, so the drain loop spins.

124 (set! busy (%tcp-connect-sync "127.0.0.1" http-port))

125 (socket-write busy "GET /probe HTTP/1.1\r\nHost: probe\r\n")

126 ;; give the server a chance to accept + enter the drain

127 (sleep 0.3)

128

129 (let ((starved-ms (measure-first-read-latency

130 (+ pair-port-base 1))))

131 (when busy (socket-close busy))

132

133 ;; phase 3 — stop from a sibling task: the suspended loop

134 ;; must wake on its bounded deadline and exit promptly.

135 (let ((t-stop (current-milliseconds)))

136 (http-server-stop srv)

137 (let ((stop-ms

138 (let wait ()

139 (cond

140 (server-returned

141 (- (current-milliseconds) t-stop))

142 ((> (- (current-milliseconds) t-stop)

143 watchdog-ms)

144 -1)

145 (else

146 (sleep 0.1)

147 (wait))))))

148 (display (string-append

149 "control-ms=" (number->string control-ms)

150 " starved-ms=" (number->string starved-ms)

151 " stop-ms=" (number->string stop-ms)

152 "\n"))

153 (cond

154 ((< control-ms 0)

155 (display "FAIL: control measurement starved — harness broken\n")

156 (exit 2))

157 ((< starved-ms 0)

158 (display "STARVED: io-waiter never serviced while drain busy\n")

159 (exit 1))

160 ((> starved-ms 2000)

161 (display "DEGRADED: io-waiter serviced but late\n")

162 (exit 1))

163 ((< stop-ms 0)

164 (display "STOP-HUNG: http-server-stop did not stop the serve loop\n")

165 (exit 1))

166 ((> stop-ms 3000)

167 (display "STOP-SLOW: serve loop exited but late\n")

168 (exit 1))

169 (else

170 (display "OK: io-waiter serviced promptly under load; stop prompt\n")

171 (exit 0)))))))))))))