Yield during cold cache fills and task parsing

Changed

 src/folio/filecache.sgl             | 21 +++++++++++++--------
 src/folio/scheduling.sgl            | 20 ++++++++++++++++++++
 src/folio/task.sgl                  |  7 +++++--
 test/test-cold-cache-scheduling.sgl | 75 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 113 insertions(+), 10 deletions(-)

Diff

src/folio/filecache.sglmodified

@@ -25,6 +25,7 @@

;;; immutable (folio's structs, dicts and lists are).

(define-library (folio filecache)

(import (sigil fs)

+28

(folio scheduling)

(sigil string)

(sigil time))

(export make-file-cache

@@ -44,10 +45,11 @@

(and (< (list-ref signature 3) cutoff-ns)

(< (list-ref signature 4) cutoff-ns))))

−47

;; A cache is a box holding a dict: path -> (signature . value).

+48

;; A cache holds path -> (signature . value), plus a checkpoint shared

+49

;; across misses so a cold batch does not monopolize the HTTP scheduler.

(define (make-file-cache)

(: -> vector?)

−50

(vector (dict)))

+52

(vector (dict) (make-work-checkpoint)))

;;; Return (compute path), reusing the value from an earlier call while

;;; the file's stat signature is unchanged. A missing file is never cached.

@@ -60,12 +62,15 @@

(let ((hit (dict-ref (vector-ref cache 0) path #f)))

(if (and hit (equal? (car hit) before))

(cdr hit)

−63

(let* ((value (compute path))

−64

(after (file-stat-fingerprint path)))

−65

(when (and (equal? before after) (settled? before))

−66

(vector-set! cache 0

−67

(dict-set (vector-ref cache 0) path (cons before value))))

−68

value))))))

+65

(let ((value (compute path)))

+66

((vector-ref cache 1))

+67

;; Recheck after the checkpoint: a writer may have run

+68

;; while this task was paused. Cache only matching bytes.

+69

(let ((after (file-stat-fingerprint path)))

+70

(when (and (equal? before after) (settled? before))

+71

(vector-set! cache 0

+72

(dict-set (vector-ref cache 0) path (cons before value))))

+73

value)))))))

(define (file-cache-size cache)

(: vector? -> integer?)

src/folio/scheduling.sgladded

@@ -0,0 +1,20 @@

;;; Cooperative checkpoints for bulk file parsing in the shared server.

;;; They do nothing outside an async scheduler. A checkpoint cannot interrupt

;;; one native operation; callers place it between bounded pieces of work.

(define-library (folio scheduling)

(import (sigil async scheduler)

(sigil time))

(export make-work-checkpoint)

(begin

+10

(define (make-work-checkpoint)

+11

(: -> procedure?)

+12

(let ((last-poll (current-jiffy))

+13

(budget (/ (jiffies-per-second) 100)))

+14

(lambda ()

+15

(when (and (current-scheduler)

+16

(>= (- (current-jiffy) last-poll) budget))

+17

;; A positive timer lets the scheduler poll sockets promptly,

+18

;; even when other runnable tasks keep its queue nonempty.

+19

(sleep 0.001)

+20

(set! last-poll (current-jiffy))))))))

src/folio/task.sglmodified

@@ -45,7 +45,7 @@

;;; archive/tasks/folio-inbox-integrity-and-bulk-moves.

(define-library (folio task)

−48

(import (sigil core)

+48

(import (folio scheduling)

(sigil struct)

(sigil string))

(export folio-task

@@ -161,8 +161,10 @@

161

;;; 1-based header line number).

162

(define (find-task-blocks lines . opts)

163

(: list? -> list?)

−164

(let ((file (if (pair? opts) (car opts) #f)))

+164

(let ((file (if (pair? opts) (car opts) #f))

+165

(checkpoint (make-work-checkpoint)))

166

(let loop ((rest lines) (idx 0) (blocks '()))

+167

(checkpoint)

168

(cond

169

((null? rest) (reverse blocks))

170

((task-line? (car rest))

@@ -174,6 +176,7 @@

176

;; non-blank under-indented line ends the run.

177

(end (let scan ((r (cdr rest)) (i (+ idx 1)) (last idx)

178

(blanks 0))

+179

(checkpoint)

180

(cond

181

((null? r) last)

182

((blank-line? (car r))

test/test-cold-cache-scheduling.sgladded

@@ -0,0 +1,75 @@

;;; Cold parsing must let another request run without caching a raced value.

(import (sigil test)

(sigil fs)

(sigil path)

(sigil time)

(sigil async)

(sigil channels)

(folio lock)

(folio filecache)

+10

(folio task))

+11

+12

(test-group "cold parsing checkpoints"

+13

(test "a writer during a cache-fill pause invalidates the computed value"

+14

(call-with-temp-directory

+15

(lambda (root)

+16

(let* ((path (path-join root "value.md"))

+17

(cache (make-file-cache))

+18

(ready (make-channel 1))

+19

(first #f)

+20

(size-after-first #f)

+21

(writer-ran? #f))

+22

(write-file-string path "old")

+23

(parameterize ((file-cache-settle-seconds 0))

+24

(with-async

+25

(go

+26

(channel-receive ready)

+27

(write-file-atomic path "new")

+28

(set! writer-ran? #t))

+29

(go

+30

;; Model a native CPU phase; explicit checkpoints must work

+31

;; without relying on the VM's automatic preemption.

+32

(set-vm-yield-requested! #f)

+33

(set! first

+34

(file-cache-ref cache path

+35

(lambda (p)

+36

(let ((value (read-file-string p))

+37

(start (current-jiffy)))

+38

(channel-send ready #t)

+39

(let busy ()

+40

(when (< (- (current-jiffy) start)

+41

(/ (jiffies-per-second) 50))

+42

(busy)))

+43

value))))

+44

(set! size-after-first (file-cache-size cache))))

+45

(display (format "COLD-CACHE writer-ran=~a first=~a cached=~a\n"

+46

writer-ran? first size-after-first))

+47

(assert-true writer-ran?)

+48

(assert-equal "old" first)

+49

(assert-equal 0 size-after-first)

+50

(assert-equal "new" (file-cache-ref cache path read-file-string)))))))

+51

+52

(test "a sibling runs before a cold task-block parse finishes"

+53

(let ((ready (make-channel 1))

+54

(finished? #f)

+55

(interleaved? #f)

+56

(blocks '())

+57

(lines

+58

(let loop ((n 0) (acc '()))

+59

(if (= n 2000)

+60

(reverse acc)

+61

(loop (+ n 1)

+62

(cons (format "- [ ] Task ~a {id: t-~a}" n n) acc))))))

+63

(with-async

+64

(go

+65

(channel-receive ready)

+66

(set! interleaved? (not finished?)))

+67

(go

+68

(set-vm-yield-requested! #f)

+69

(channel-send ready #t)

+70

(set! blocks (find-task-blocks lines))

+71

(set! finished? #t)))

+72

(display (format "COLD-PARSE interleaved=~a blocks=~a\n"

+73

interleaved? (length blocks)))

+74

(assert-true interleaved?)

+75

(assert-equal 2000 (length blocks)))))