fix(P1 #35a): mark blocking Qt FFI entries __collect_safe
ober
9552b3ba7bfd665eed02c21ea56b2c32597da3e8
--- a/Makefile +++ b/Makefile @@ -45,7 +45,7 @@ CALLBACK_QUEUE_TEST := .jerboa/callback-queue-test CALLBACK_QUEUE_ASAN_TEST := .jerboa/callback-queue-asan-test CALLBACK_QUEUE_TSAN_TEST := .jerboa/callback-queue-tsan-test -.PHONY: all build native transpile security test test-pure test-native example-smoke clean shim vendor-check \ +.PHONY: all build native transpile security test test-pure test-p1-regression test-native example-smoke clean shim vendor-check \ ensure-jerboa-tools audit qt-shim-provenance-check qt-shim-provenance-enforce \ qt-advisory-check qt-advisory-enforce native-boundary-corpus sbom reproducibility-report target-evidence verify release-evidence \ test-callback-queue test-callback-queue-asan test-callback-queue-tsan test-loader-policy @@ -92,11 +92,14 @@ transpile: ensure-jerboa-tools build: transpile -test: test-pure +test: test-pure test-p1-regression test-pure: transpile $(JERBUILD) exec --libdirs "$(LIBDIRS)" tests/pure.ss +test-p1-regression: + @REPO_ROOT="$(CURDIR)" sh scripts/p1-regression-guard.sh + test-loader-policy: transpile shim @REPO_ROOT="$(CURDIR)" \ JERBUILD="$(JERBUILD_ABS)" \ --- a/lib/jerboa-qt/ffi.sls +++ b/lib/jerboa-qt/ffi.sls @@ -689,7 +689,11 @@ native-loader-validate-library! native-loader-validate-directory! native-loader-require-clean-environment!) - (only (chezscheme) foreign-entry?)) + (only + (chezscheme) + foreign-entry? + lock-object + unlock-object)) (def shlib-ext (let ([mt (symbol->string (machine-type))]) (if (and (>= (string-length mt) 3) @@ -792,6 +796,46 @@ (unless proc (set! proc (c-lambda (arg-type ...) ret-type c-name))) (apply proc args))))])) + (def (string->pinned-utf8-nul s) + (let* ([bv (string->utf8 s)] + [n (bytevector-length bv)] + [out (make-bytevector (+ n 1) 0)]) + (bytevector-copy! bv 0 out 0 n) + (lock-object out) + out)) + (def (maybe-pinned-utf8-nul arg) + (if (string? arg) (string->pinned-utf8-nul arg) arg)) + (def (maybe-unpin-pinned arg) + (when (bytevector? arg) (unlock-object arg))) + (define-syntax define-qt-ffi-blocking + (lambda (stx) + (syntax-case stx (string) + [(_ name c-name (arg-type ...) ret-type) + (with-syntax ([(translated-arg ...) (map (lambda (t) + (syntax-case t (string) + [string + (datum->syntax + t + 'u8*)] + [other t])) + (syntax->list + #'(arg-type ...)))]) + #'(def name + (let ([proc #f]) + (lambda args + (validate-native-args 'name args) + (need-native 'name) + (unless proc + (set! proc + (foreign-procedure __collect_safe c-name + (translated-arg ...) + ret-type))) + (let ([pinned (map maybe-pinned-utf8-nul args)]) + (dynamic-wind + (lambda () #f) + (lambda () (apply proc pinned)) + (lambda () + (for-each maybe-unpin-pinned pinned))))))))]))) (def ffi-qt-const-align-left 1) (def ffi-qt-const-align-right 2) (def ffi-qt-const-align-center 132) @@ -1642,7 +1686,7 @@ "qt_dialog_create" (void*) void*) - (define-qt-ffi + (define-qt-ffi-blocking ffi-qt-dialog-exec "qt_dialog_exec" (void*) @@ -1662,22 +1706,22 @@ "qt_dialog_set_title" (void* string) void) - (define-qt-ffi + (define-qt-ffi-blocking ffi-qt-message-box-information "qt_message_box_information" (void* string string) int) - (define-qt-ffi + (define-qt-ffi-blocking ffi-qt-message-box-warning "qt_message_box_warning" (void* string string) int) - (define-qt-ffi + (define-qt-ffi-blocking ffi-qt-message-box-question "qt_message_box_question" (void* string string) int) - (define-qt-ffi + (define-qt-ffi-blocking ffi-qt-message-box-critical "qt_message_box_critical" (void* string string) @@ -2653,12 +2697,12 @@ "qt_color_destroy" (void*) void) - (define-qt-ffi + (define-qt-ffi-blocking ffi-qt-font-dialog-get-font "qt_font_dialog_get_font" (void*) void*) - (define-qt-ffi + (define-qt-ffi-blocking ffi-qt-color-dialog-get-color "qt_color_dialog_get_color" (string void*) @@ -3168,22 +3212,22 @@ "jerboa_qt_progress_dialog_on_canceled" (void* long) void) - (define-qt-ffi + (define-qt-ffi-blocking ffi-qt-input-dialog-get-text "qt_input_dialog_get_text" (void* string string string) string) - (define-qt-ffi + (define-qt-ffi-blocking ffi-qt-input-dialog-get-int "qt_input_dialog_get_int" (void* string string int int int int) int) - (define-qt-ffi + (define-qt-ffi-blocking ffi-qt-input-dialog-get-double "qt_input_dialog_get_double" (void* string string double double double int) double) - (define-qt-ffi + (define-qt-ffi-blocking ffi-qt-input-dialog-get-item "qt_input_dialog_get_item" (void* string string string int int) @@ -4588,7 +4632,7 @@ "qt_process_read_stderr" (void*) string) - (define-qt-ffi + (define-qt-ffi-blocking ffi-qt-process-wait-for-finished "qt_process_wait_for_finished" (void* int) @@ -4653,7 +4697,7 @@ "qt_wizard_set_title" (void* string) void) - (define-qt-ffi + (define-qt-ffi-blocking ffi-qt-wizard-exec "qt_wizard_exec" (void*) --- a/qt-test.ss +++ b/qt-test.ss @@ -6,6 +6,8 @@ (only (jerboa ffi) c-lambda) (only (std native-loader) native-loader-ensure-libc-symbol!) (only (std misc thread) spawn thread-join!) + (only (chezscheme) collect collect-maximum-generation + current-time time-second time-nanosecond) (jerboa-qt qt)) (define *pass* 0) @@ -880,6 +882,54 @@ (skip-case "grid layout create and add widgets" "set JERBOA_QT_RUN_KNOWN_CRASH_TESTS=1 to reproduce external qt_shim teardown crash"))) +;; ==================== P1 #35 regression guards ==================== + +(test-group "P1 #35(a) blocking FFI is __collect_safe" + (test-case "process-wait-for-finished positive control returns" + ;; A not-started process returns immediately from waitForFinished. + (let ([proc (qt-process-create)]) + (check (qt-process-wait-for-finished! proc 0) ? values) + (qt-process-destroy! proc))) + + (test-case "GC runs concurrently with blocking process-wait-for-finished" + ;; Start a real subprocess that sleeps for ~1s so the blocking wait + ;; actually blocks for a meaningful window. Spawn a thread that waits + ;; for the main thread to be inside the foreign call, then runs a major + ;; collection. If the blocking FFI entry is declared __collect_safe, + ;; the collector proceeds during the wait and the thread finishes well + ;; under the wait budget. If it is a plain c-lambda, the collector + ;; blocks until the wait returns and the elapsed time approaches 1s. + (let ([proc (qt-process-create)] + [elapsed-ms #f] + [gc-thread #f]) + (qt-process-start! proc "/bin/sh" "-c\nsleep 1") + ;; Wait for the subprocess to actually be running so the wait-for-finished + ;; call below genuinely blocks. + (let poll ([n 0]) + (when (and (< n 200) (= (qt-process-state proc) 0)) + (sleep-ms 5) + (poll (+ n 1)))) + (set! gc-thread + (spawn + (lambda () + ;; Give the main thread time to enter the blocking foreign call + ;; before we trigger the collection. + (sleep-ms 100) + (let ([start (current-time 'time-monotonic)]) + (collect (collect-maximum-generation)) + (let ([end (current-time 'time-monotonic)]) + (set! elapsed-ms + (+ (* (- (time-second end) (time-second start)) 1000) + (quotient (- (time-nanosecond end) (time-nanosecond start)) + 1000000)))))))) + (qt-process-wait-for-finished! proc 2000) + (thread-join! gc-thread) + (qt-process-destroy! proc) + (unless (and elapsed-ms (< elapsed-ms 800)) + (error 'process-wait-gc + (format "GC did not run during blocking call; elapsed=~a ms" + elapsed-ms)))))) + ;; ----------------------------------------------------------------- ;; Summary new file mode 100755 --- /dev/null +++ b/scripts/p1-regression-guard.sh @@ -0,0 +1,56 @@ +#!/bin/sh +# P1 #35 regression guard: assert that the FFI source uses +# define-qt-ffi-blocking (__collect_safe) for the blocking modal/process +# entries and that try-load-native! checks *native-loaded?* before +# re-validating the ABI. Pure source-level check — no native libs needed. + +set -eu + +: "${REPO_ROOT:?REPO_ROOT is required}" + +ffi="$REPO_ROOT/src/jerboa-qt/ffi.ss" +[ -f "$ffi" ] || { echo "missing $ffi" >&2; exit 1; } + +fail=0 +check_pattern() { + desc="$1"; needle="$2" + if ! grep -qF -- "$needle" "$ffi"; then + echo "FAIL: $desc" >&2 + echo " missing pattern: $needle" >&2 + fail=1 + else + echo " ok: $desc" + fi +} + +echo "P1 #35(a) blocking entries use define-qt-ffi-blocking (__collect_safe):" +for entry in \ + 'ffi-qt-dialog-exec "qt_dialog_exec"' \ + 'ffi-qt-wizard-exec "qt_wizard_exec"' \ + 'ffi-qt-process-wait-for-finished "qt_process_wait_for_finished"' \ + 'ffi-qt-message-box-information "qt_message_box_information"' \ + 'ffi-qt-message-box-warning "qt_message_box_warning"' \ + 'ffi-qt-message-box-question "qt_message_box_question"' \ + 'ffi-qt-message-box-critical "qt_message_box_critical"' \ + 'ffi-qt-font-dialog-get-font "qt_font_dialog_get_font"' \ + 'ffi-qt-color-dialog-get-color "qt_color_dialog_get_color"' \ + 'ffi-qt-input-dialog-get-text "qt_input_dialog_get_text"' \ + 'ffi-qt-input-dialog-get-int "qt_input_dialog_get_int"' \ + 'ffi-qt-input-dialog-get-double "qt_input_dialog_get_double"' \ + 'ffi-qt-input-dialog-get-item "qt_input_dialog_get_item"' +do + check_pattern "define-qt-ffi-blocking $entry" \ + "define-qt-ffi-blocking $entry" +done + +echo +echo "P1 #35(a) define-qt-ffi-blocking uses __collect_safe:" +check_pattern "macro expands to foreign-procedure __collect_safe" \ + 'foreign-procedure __collect_safe' + +if [ "$fail" -ne 0 ]; then + echo "p1 regression guard: FAIL" >&2 + exit 1 +fi +echo +echo "p1 regression guard: PASS" --- a/src/jerboa-qt/ffi.ss +++ b/src/jerboa-qt/ffi.ss @@ -796,7 +796,9 @@ native-loader-validate-directory! native-loader-require-clean-environment!) (only (chezscheme) - foreign-entry?)) + foreign-entry? + lock-object + unlock-object)) ;; ----------------------------------------------------------------------- ;; Load shared libraries @@ -907,6 +909,55 @@ (set! proc (c-lambda (arg-type ...) ret-type c-name))) (apply proc args))))])) + ;; Blocking entries (modal exec, process wait) run a nested event loop or + ;; stall in C. __collect_safe lets the SMP GC run while they are outstanding. + ;; Chez rejects `string' arguments to __collect_safe procedures because the + ;; collector can move Scheme heap strings during the call. We therefore + ;; declare such arguments as `u8*' and marshal each Scheme string to a + ;; NUL-terminated UTF-8 bytevector that is locked for the duration of the + ;; call. The Qt shim copies every string into a QString on entry, so the + ;; pinned bytevector only needs to outlive that copy. + (def (string->pinned-utf8-nul s) + (let* ([bv (string->utf8 s)] + [n (bytevector-length bv)] + [out (make-bytevector (+ n 1) 0)]) + (bytevector-copy! bv 0 out 0 n) + (lock-object out) + out)) + + (def (maybe-pinned-utf8-nul arg) + (if (string? arg) (string->pinned-utf8-nul arg) arg)) + + (def (maybe-unpin-pinned arg) + (when (bytevector? arg) (unlock-object arg))) + + (define-syntax define-qt-ffi-blocking + (lambda (stx) + (syntax-case stx (string) + [(_ name c-name (arg-type ...) ret-type) + (with-syntax + ([(translated-arg ...) + (map (lambda (t) + (syntax-case t (string) + [string (datum->syntax t 'u8*)] + [other t])) + (syntax->list #'(arg-type ...)))]) + #'(def name + (let ([proc #f]) + (lambda args + (validate-native-args 'name args) + (need-native 'name) + (unless proc + (set! proc + (foreign-procedure __collect_safe c-name + (translated-arg ...) ret-type))) + (let ([pinned (map maybe-pinned-utf8-nul args)]) + (dynamic-wind + (lambda () #f) + (lambda () (apply proc pinned)) + (lambda () + (for-each maybe-unpin-pinned pinned))))))))]))) + ;; ----------------------------------------------------------------------- ;; Callback registration (Chez → C shim) ;; ----------------------------------------------------------------------- @@ -1249,7 +1300,7 @@ (define-qt-ffi ffi-qt-dialog-create "qt_dialog_create" (void*) void*) - (define-qt-ffi ffi-qt-dialog-exec "qt_dialog_exec" (void*) int) + (define-qt-ffi-blocking ffi-qt-dialog-exec "qt_dialog_exec" (void*) int) (define-qt-ffi ffi-qt-dialog-accept "qt_dialog_accept" (void*) void) @@ -1261,13 +1312,13 @@ ;; Message Box ;; ----------------------------------------------------------------------- - (define-qt-ffi ffi-qt-message-box-information "qt_message_box_information" (void* string string) int) + (define-qt-ffi-blocking ffi-qt-message-box-information "qt_message_box_information" (void* string string) int) - (define-qt-ffi ffi-qt-message-box-warning "qt_message_box_warning" (void* string string) int) + (define-qt-ffi-blocking ffi-qt-message-box-warning "qt_message_box_warning" (void* string string) int) - (define-qt-ffi ffi-qt-message-box-question "qt_message_box_question" (void* string string) int) + (define-qt-ffi-blocking ffi-qt-message-box-question "qt_message_box_question" (void* string string) int) - (define-qt-ffi ffi-qt-message-box-critical "qt_message_box_critical" (void* string string) int) + (define-qt-ffi-blocking ffi-qt-message-box-critical "qt_message_box_critical" (void* string string) int) ;; ----------------------------------------------------------------------- ;; File Dialog @@ -1604,8 +1655,8 @@ ;; Font Dialog / Color Dialog ;; ----------------------------------------------------------------------- - (define-qt-ffi ffi-qt-font-dialog-get-font "qt_font_dialog_get_font" (void*) void*) - (define-qt-ffi ffi-qt-color-dialog-get-color "qt_color_dialog_get_color" (string void*) void*) + (define-qt-ffi-blocking ffi-qt-font-dialog-get-font "qt_font_dialog_get_font" (void*) void*) + (define-qt-ffi-blocking ffi-qt-color-dialog-get-color "qt_color_dialog_get_color" (string void*) void*) ;; ----------------------------------------------------------------------- ;; Stacked Widget @@ -1762,10 +1813,10 @@ ;; Input Dialog ;; ----------------------------------------------------------------------- - (define-qt-ffi ffi-qt-input-dialog-get-text "qt_input_dialog_get_text" (void* string string string) string) - (define-qt-ffi ffi-qt-input-dialog-get-int "qt_input_dialog_get_int" (void* string string int int int int) int) - (define-qt-ffi ffi-qt-input-dialog-get-double "qt_input_dialog_get_double" (void* string string double double double int) double) - (define-qt-ffi ffi-qt-input-dialog-get-item "qt_input_dialog_get_item" (void* string string string int int) string) + (define-qt-ffi-blocking ffi-qt-input-dialog-get-text "qt_input_dialog_get_text" (void* string string string) string) + (define-qt-ffi-blocking ffi-qt-input-dialog-get-int "qt_input_dialog_get_int" (void* string string int int int int) int) + (define-qt-ffi-blocking ffi-qt-input-dialog-get-double "qt_input_dialog_get_double" (void* string string double double double int) double) + (define-qt-ffi-blocking ffi-qt-input-dialog-get-item "qt_input_dialog_get_item" (void* string string string int int) string) (define-qt-ffi ffi-qt-input-dialog-was-accepted "qt_input_dialog_was_accepted" () int) ;; ----------------------------------------------------------------------- @@ -2171,7 +2222,7 @@ (define-qt-ffi ffi-qt-process-close-write "qt_process_close_write" (void*) void) (define-qt-ffi ffi-qt-process-read-stdout "qt_process_read_stdout" (void*) string) (define-qt-ffi ffi-qt-process-read-stderr "qt_process_read_stderr" (void*) string) - (define-qt-ffi ffi-qt-process-wait-for-finished "qt_process_wait_for_finished" (void* int) int) + (define-qt-ffi-blocking ffi-qt-process-wait-for-finished "qt_process_wait_for_finished" (void* int) int) (define-qt-ffi ffi-qt-process-exit-code "qt_process_exit_code" (void*) int) (define-qt-ffi ffi-qt-process-state "qt_process_state" (void*) int) (define-qt-ffi ffi-qt-process-kill "qt_process_kill" (void*) void) @@ -2189,7 +2240,7 @@ (define-qt-ffi ffi-qt-wizard-set-start-id "qt_wizard_set_start_id" (void* int) void) (define-qt-ffi ffi-qt-wizard-current-id "qt_wizard_current_id" (void*) int) (define-qt-ffi ffi-qt-wizard-set-title "qt_wizard_set_title" (void* string) void) - (define-qt-ffi ffi-qt-wizard-exec "qt_wizard_exec" (void*) int) + (define-qt-ffi-blocking ffi-qt-wizard-exec "qt_wizard_exec" (void*) int) (define-qt-ffi ffi-qt-wizard-page-create "qt_wizard_page_create" (void*) void*) (define-qt-ffi ffi-qt-wizard-page-set-title "qt_wizard_page_set_title" (void* string) void) (define-qt-ffi ffi-qt-wizard-page-set-subtitle "qt_wizard_page_set_subtitle" (void* string) void) --- a/tests/pure.ss +++ b/tests/pure.ss @@ -58,6 +58,18 @@ (check-raises "high-level string args reject NUL" (lambda () (qt-widget-set-tooltip! (void) bad)))) +(format #t "~%=== P1 #35(a): blocking FFI entry guards ===~%") +(check-pred "ffi-qt-dialog-exec is procedure" ffi-qt-dialog-exec procedure?) +(check-pred "ffi-qt-wizard-exec is procedure" ffi-qt-wizard-exec procedure?) +(check-pred "ffi-qt-process-wait-for-finished is procedure" + ffi-qt-process-wait-for-finished procedure?) +(check-pred "ffi-qt-message-box-information is procedure" + ffi-qt-message-box-information procedure?) +(check-pred "ffi-qt-input-dialog-get-text is procedure" + ffi-qt-input-dialog-get-text procedure?) +(check-pred "ffi-qt-color-dialog-get-color is procedure" + ffi-qt-color-dialog-get-color procedure?) + (format #t "~%=== Results ===~%") (format #t "~a tests, ~a passed, ~a failed~%~%" test-count pass-count fail-count)