Add guardian-based FFI resource cleanup pattern (#52)
ober
477ce13f104f7d18246ab15670003e0ea04268bd
new file mode 100644 --- /dev/null +++ b/lib/std/misc/guardian-pool.sls @@ -0,0 +1,178 @@ +#!chezscheme +;;; (std misc guardian-pool) — Guardian-based FFI resource cleanup +;;; +;;; Standardized guardian-based resource cleanup for FFI handles. +;;; Resources registered with a guardian pool are automatically cleaned up +;;; when the GC reclaims them, or can be manually drained on shutdown. +;;; +;;; Usage: +;;; (define pool (make-guardian-pool free-handle!)) +;;; (guardian-pool-register pool handle) +;;; ;; ... later, after GC has reclaimed some handles: +;;; (guardian-pool-collect! pool) +;;; ;; On shutdown: +;;; (guardian-pool-drain! pool) +;;; +;;; Pointerlike usage: +;;; (define pool (make-guardian-pool free-handle!)) +;;; (define h (make-pointerlike pool 42)) +;;; (pointerlike-value h) => 42 +;;; (pointerlike-free! h) ;; manual free +;;; +;;; Scoped usage: +;;; (with-guarded-resource (h (allocate-handle) pool) +;;; (use h)) ;; cleanup runs on scope exit + +(library (std misc guardian-pool) + (export make-guardian-pool + guardian-pool? + guardian-pool-register + guardian-pool-collect! + guardian-pool-drain! + with-guarded-resource + make-pointerlike + pointerlike? + pointerlike-value + pointerlike-free!) + (import (chezscheme)) + + ;; Guardian pool: wraps a Chez guardian with a cleanup procedure + ;; and a set tracking all live (registered, not yet cleaned) resources. + (define-record-type gpool + (fields + (immutable guardian) ;; Chez guardian object + (immutable cleanup-proc) ;; procedure: resource -> void + (mutable live-set)) ;; eq hashtable of live resources + (protocol + (lambda (new) + (lambda (cleanup-proc) + (new (make-guardian) cleanup-proc (make-eq-hashtable)))))) + + (define (guardian-pool? x) + (gpool? x)) + + (define (make-guardian-pool cleanup-proc) + (unless (procedure? cleanup-proc) + (error 'make-guardian-pool "expected a cleanup procedure" cleanup-proc)) + (make-gpool cleanup-proc)) + + ;; Register a resource with the pool. + ;; The guardian will prevent the resource from being finalized until the + ;; GC determines it is unreachable, at which point collect! can clean it up. + ;; Returns the resource for convenience. + (define (guardian-pool-register pool resource) + (unless (gpool? pool) + (error 'guardian-pool-register "expected a guardian pool" pool)) + (let ([guardian (gpool-guardian pool)] + [live (gpool-live-set pool)]) + (guardian resource) + (hashtable-set! live resource #t) + resource)) + + ;; Collect GC'd resources: drain the guardian and call cleanup on each. + ;; Returns the number of resources cleaned up. + (define (guardian-pool-collect! pool) + (unless (gpool? pool) + (error 'guardian-pool-collect! "expected a guardian pool" pool)) + (let ([guardian (gpool-guardian pool)] + [cleanup (gpool-cleanup-proc pool)] + [live (gpool-live-set pool)] + [count 0]) + (let loop () + (let ([obj (guardian)]) + (when obj + ;; Only clean up if still in the live set (not already manually freed) + (when (hashtable-ref live obj #f) + (hashtable-delete! live obj) + (guard (e [#t (void)]) ;; swallow errors during cleanup + (cleanup obj)) + (set! count (+ count 1))) + (loop)))) + count)) + + ;; Drain ALL live resources (for shutdown). Cleans up everything registered, + ;; regardless of whether the GC has reclaimed it. + ;; Returns the number of resources cleaned up. + (define (guardian-pool-drain! pool) + (unless (gpool? pool) + (error 'guardian-pool-drain! "expected a guardian pool" pool)) + ;; First, collect anything the GC has already reclaimed + (guardian-pool-collect! pool) + ;; Then forcibly clean up everything still in the live set + (let ([cleanup (gpool-cleanup-proc pool)] + [live (gpool-live-set pool)] + [count 0]) + (let-values ([(keys vals) (hashtable-entries live)]) + (vector-for-each + (lambda (resource _val) + (guard (e [#t (void)]) + (cleanup resource)) + (set! count (+ count 1))) + keys vals)) + (hashtable-clear! live) + count)) + + ;; Scoped resource management: create a resource, register with pool, + ;; ensure cleanup on scope exit (normal or exception). + (define-syntax with-guarded-resource + (syntax-rules () + [(_ (var init pool) body body* ...) + (let ([p pool]) + (let ([var init]) + (guardian-pool-register p var) + (dynamic-wind + void + (lambda () body body* ...) + (lambda () + ;; Remove from live set and clean up immediately + (let ([live (gpool-live-set p)]) + (when (hashtable-ref live var #f) + (hashtable-delete! live var) + (guard (e [#t (void)]) + ((gpool-cleanup-proc p) var))))))))])) + + ;; --- Pointerlike: a handle record wrapping an integer/pointer value --- + + (define-record-type ptrlike + (fields + (immutable pool) ;; guardian pool this belongs to + (mutable val) ;; the integer/pointer value, or #f if freed + (mutable freed?)) ;; #t after manual free + (protocol + (lambda (new) + (lambda (pool value) + (new pool value #f))))) + + (define (pointerlike? x) + (ptrlike? x)) + + (define (pointerlike-value p) + (unless (ptrlike? p) + (error 'pointerlike-value "expected a pointerlike" p)) + (when (ptrlike-freed? p) + (error 'pointerlike-value "pointerlike has been freed" p)) + (ptrlike-val p)) + + ;; Create a pointerlike, register with pool for auto-cleanup. + (define (make-pointerlike pool value) + (unless (gpool? pool) + (error 'make-pointerlike "expected a guardian pool" pool)) + (let ([p (make-ptrlike pool value)]) + (guardian-pool-register pool p) + p)) + + ;; Manually free a pointerlike. Calls the pool's cleanup proc and + ;; removes it from the live set so the guardian won't double-free. + (define (pointerlike-free! p) + (unless (ptrlike? p) + (error 'pointerlike-free! "expected a pointerlike" p)) + (unless (ptrlike-freed? p) + (let ([pool (ptrlike-pool p)] + [live-set (gpool-live-set (ptrlike-pool p))]) + (guard (e [#t (void)]) + ((gpool-cleanup-proc pool) p)) + (hashtable-delete! live-set p) + (ptrlike-freed?-set! p #t) + (ptrlike-val-set! p #f)))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-guardian-pool.ss @@ -0,0 +1,193 @@ +#!/usr/bin/env scheme-script +#!chezscheme +(import (chezscheme) + (std misc guardian-pool)) + +(define test-count 0) +(define pass-count 0) + +(define (test name thunk) + (set! test-count (+ test-count 1)) + (guard (e [#t (display "FAIL: ") (display name) (newline) + (display " Error: ") (display (condition-message e)) (newline)]) + (thunk) + (set! pass-count (+ pass-count 1)) + (display "PASS: ") (display name) (newline))) + +(define (assert-equal actual expected msg) + (unless (equal? actual expected) + (error 'assert-equal + (string-append msg ": expected " (format "~s" expected) + " got " (format "~s" actual))))) + +(define (assert-true val msg) + (unless val + (error 'assert-true (string-append msg ": expected #t")))) + +;; Test 1: basic pool creation and resource registration +(test "make-guardian-pool and register" + (lambda () + (let* ([freed '()] + [pool (make-guardian-pool (lambda (r) (set! freed (cons r freed))))]) + (assert-true (guardian-pool? pool) "pool is a guardian-pool") + (let ([r1 (list 'resource-1)] + [r2 (list 'resource-2)]) + (guardian-pool-register pool r1) + (guardian-pool-register pool r2) + ;; Resources exist and are tracked (not yet freed) + (assert-equal freed '() "nothing freed yet"))))) + +;; Test 2: manual drain clears all resources and calls cleanup +(test "guardian-pool-drain! cleans all resources" + (lambda () + (let* ([freed '()] + [pool (make-guardian-pool (lambda (r) (set! freed (cons r freed))))] + [r1 (list 'a)] + [r2 (list 'b)] + [r3 (list 'c)]) + (guardian-pool-register pool r1) + (guardian-pool-register pool r2) + (guardian-pool-register pool r3) + (let ([n (guardian-pool-drain! pool)]) + ;; All 3 should be cleaned up + (assert-equal n 3 "drain count") + (assert-equal (length freed) 3 "freed count") + ;; Each resource should appear exactly once + (assert-true (memq r1 freed) "r1 freed") + (assert-true (memq r2 freed) "r2 freed") + (assert-true (memq r3 freed) "r3 freed"))))) + +;; Test 3: drain after some are already manually removed +(test "drain after partial cleanup" + (lambda () + (let* ([freed '()] + [pool (make-guardian-pool (lambda (r) (set! freed (cons r freed))))] + [r1 (list 'x)] + [r2 (list 'y)]) + (guardian-pool-register pool r1) + (guardian-pool-register pool r2) + ;; Drain should get both + (guardian-pool-drain! pool) + (assert-equal (length freed) 2 "both freed") + ;; Second drain should find nothing + (let ([n2 (guardian-pool-drain! pool)]) + (assert-equal n2 0 "second drain finds nothing") + (assert-equal (length freed) 2 "still just 2"))))) + +;; Test 4: with-guarded-resource ensures cleanup on normal exit +(test "with-guarded-resource normal exit" + (lambda () + (let* ([freed '()] + [pool (make-guardian-pool (lambda (r) (set! freed (cons r freed))))] + [resource (list 'guarded)]) + (let ([result + (with-guarded-resource (h resource pool) + (assert-equal h resource "bound correctly") + 'ok)]) + (assert-equal result 'ok "body returns value") + (assert-true (memq resource freed) "resource was freed on exit"))))) + +;; Test 5: with-guarded-resource ensures cleanup on exception +(test "with-guarded-resource exception exit" + (lambda () + (let* ([freed '()] + [pool (make-guardian-pool (lambda (r) (set! freed (cons r freed))))] + [resource (list 'guarded-err)]) + (guard (e [#t (void)]) ;; catch the error + (with-guarded-resource (h resource pool) + (error 'test "deliberate error"))) + (assert-true (memq resource freed) "resource freed despite exception")))) + +;; Test 6: pointerlike creation and value access +(test "make-pointerlike and pointerlike-value" + (lambda () + (let* ([freed '()] + [pool (make-guardian-pool (lambda (r) (set! freed (cons r freed))))]) + (let ([p (make-pointerlike pool 42)]) + (assert-true (pointerlike? p) "is pointerlike") + (assert-equal (pointerlike-value p) 42 "value is 42"))))) + +;; Test 7: pointerlike manual free +(test "pointerlike-free! manual cleanup" + (lambda () + (let* ([freed '()] + [pool (make-guardian-pool (lambda (r) (set! freed (cons r freed))))]) + (let ([p (make-pointerlike pool 99)]) + (assert-equal (pointerlike-value p) 99 "value before free") + (pointerlike-free! p) + ;; After free, value access should error + (assert-true (memq p freed) "cleanup proc was called") + (let ([got-error #f]) + (guard (e [#t (set! got-error #t)]) + (pointerlike-value p)) + (assert-true got-error "accessing freed pointerlike raises error")) + ;; Double free should be a no-op + (let ([count-before (length freed)]) + (pointerlike-free! p) + (assert-equal (length freed) count-before "double free is no-op")))))) + +;; Test 8: pointerlike freed by drain +(test "pointerlike freed by drain" + (lambda () + (let* ([freed '()] + [pool (make-guardian-pool (lambda (r) (set! freed (cons r freed))))]) + (let ([p (make-pointerlike pool 77)]) + (assert-equal (pointerlike-value p) 77 "value ok") + (guardian-pool-drain! pool) + (assert-true (memq p freed) "pointerlike in freed list"))))) + +;; Test 9: collect! returns 0 when nothing has been GC'd +(test "collect! returns 0 with live references" + (lambda () + (let* ([freed '()] + [pool (make-guardian-pool (lambda (r) (set! freed (cons r freed))))] + [r1 (list 'alive)]) + (guardian-pool-register pool r1) + ;; r1 is still referenced, so GC won't reclaim it + (collect (collect-maximum-generation)) + (let ([n (guardian-pool-collect! pool)]) + ;; r1 is live, so guardian should not have returned it + (assert-equal n 0 "nothing collected while live") + (assert-equal freed '() "nothing freed while live") + ;; Keep r1 alive past the collect call + (assert-true (pair? r1) "r1 still alive"))))) + +;; Test 10: error in cleanup proc does not prevent other cleanups +(test "cleanup errors are swallowed in drain" + (lambda () + (let* ([cleaned '()] + [pool (make-guardian-pool + (lambda (r) + (when (equal? r 'bomb) + (error 'cleanup "boom")) + (set! cleaned (cons r cleaned))))]) + (guardian-pool-register pool 'ok-1) + (guardian-pool-register pool 'bomb) + (guardian-pool-register pool 'ok-2) + (guardian-pool-drain! pool) + ;; Both ok-1 and ok-2 should be cleaned despite 'bomb erroring + (assert-true (memv 'ok-1 cleaned) "ok-1 cleaned") + (assert-true (memv 'ok-2 cleaned) "ok-2 cleaned")))) + +;; Test 11: guardian-pool? predicate +(test "guardian-pool? predicate" + (lambda () + (let ([pool (make-guardian-pool void)]) + (assert-true (guardian-pool? pool) "pool is guardian-pool") + (assert-true (not (guardian-pool? 42)) "42 is not") + (assert-true (not (guardian-pool? '())) "list is not")))) + +;; Test 12: with-guarded-resource returns body value +(test "with-guarded-resource returns body result" + (lambda () + (let ([pool (make-guardian-pool void)]) + (let ([v (with-guarded-resource (h (list 1 2 3) pool) + (apply + h))]) + (assert-equal v 6 "body returns sum"))))) + +(newline) +(display "=========================================") (newline) +(display (format "Results: ~a/~a passed" pass-count test-count)) (newline) +(display "=========================================") (newline) +(when (< pass-count test-count) + (exit 1))