fix: pin input bytevectors across collect-safe FFI calls
ober
845ea683a76815dc1b9813a5d9155bbd5dd92f1a
--- a/lib/jerboa-scintilla/ffi.sls +++ b/lib/jerboa-scintilla/ffi.sls @@ -39,7 +39,7 @@ native-loader-validate-library! native-loader-validate-directory!) (only (chezscheme) file-regular? foreign-entry? make-mutex - mutex-acquire mutex-release)) + mutex-acquire mutex-release lock-object unlock-object)) (def *native-loaded?* #f) (def *bindings-ready?* #f) (def *native-lock* (make-mutex)) @@ -375,6 +375,11 @@ actual required)) (bytevector-prefix buffer actual)])))) + (def (call-with-pinned-bytevectors bvs thunk) + (dynamic-wind + (lambda () (for-each lock-object bvs)) + thunk + (lambda () (for-each unlock-object (reverse bvs))))) (def (ffi-scintilla-new) (need-native 'ffi-scintilla-new) (let ([handle (c-scintilla-new)]) @@ -397,8 +402,11 @@ 'str str)]) (need-native 'ffi-scintilla-send-message-string) - (c-scintilla-send-message-bytes handle msg wparam bv - (bytevector-length bv)))) + (call-with-pinned-bytevectors + (list bv) + (lambda () + (c-scintilla-send-message-bytes handle msg wparam bv + (bytevector-length bv)))))) (def (ffi-scintilla-receive-bytes handle msg wparam) (ensure-size 'ffi-scintilla-receive-bytes 'wparam wparam) (need-native 'ffi-scintilla-receive-bytes) @@ -422,8 +430,11 @@ 'value value)]) (need-native 'ffi-scintilla-set-property) - (c-scintilla-set-property-bytes handle msg key-bv (bytevector-length key-bv) value-bv - (bytevector-length value-bv)))) + (call-with-pinned-bytevectors + (list key-bv value-bv) + (lambda () + (c-scintilla-set-property-bytes handle msg key-bv (bytevector-length key-bv) value-bv + (bytevector-length value-bv)))))) (def (ffi-scintilla-get-property handle msg key) (let ([key-bv (string->native-bytes 'ffi-scintilla-get-property @@ -484,10 +495,13 @@ 'name name)]) (need-native 'ffi-scintilla-set-lexer-language) - (c-scintilla-set-lexer-language-bytes - handle - bv - (bytevector-length bv)))) + (call-with-pinned-bytevectors + (list bv) + (lambda () + (c-scintilla-set-lexer-language-bytes + handle + bv + (bytevector-length bv)))))) (def (ffi-scintilla-drain-one handle) (need-native 'ffi-scintilla-drain-one) (c-scintilla-drain-one handle)) @@ -606,4 +620,7 @@ 'str str)]) (need-native 'ffi-tb-print-string) - (c-tb-print-bytes x y fg bg bv (bytevector-length bv))))) + (call-with-pinned-bytevectors + (list bv) + (lambda () + (c-tb-print-bytes x y fg bg bv (bytevector-length bv))))))) --- a/src/jerboa-scintilla/ffi.ss +++ b/src/jerboa-scintilla/ffi.ss @@ -82,7 +82,8 @@ native-loader-validate-directory!) (only (chezscheme) file-regular? foreign-entry? - make-mutex mutex-acquire mutex-release)) + make-mutex mutex-acquire mutex-release + lock-object unlock-object)) (def *native-loaded?* #f) (def *bindings-ready?* #f) @@ -384,6 +385,14 @@ (error who "native result exceeded its checked capacity" actual required)) (bytevector-prefix buffer actual)])))) + ;; Pin input bytevectors across a collect-safe foreign call so a concurrent + ;; GC cannot relocate them between foreign-entry and the shim's memcpy. + (def (call-with-pinned-bytevectors bvs thunk) + (dynamic-wind + (lambda () (for-each lock-object bvs)) + thunk + (lambda () (for-each unlock-object (reverse bvs))))) + (def (ffi-scintilla-new) (need-native 'ffi-scintilla-new) (let ([handle (c-scintilla-new)]) @@ -402,7 +411,9 @@ (def (ffi-scintilla-send-message-string handle msg wparam str) (let ([bv (string->native-bytes 'ffi-scintilla-send-message-string 'str str)]) (need-native 'ffi-scintilla-send-message-string) - (c-scintilla-send-message-bytes handle msg wparam bv (bytevector-length bv)))) + (call-with-pinned-bytevectors (list bv) + (lambda () + (c-scintilla-send-message-bytes handle msg wparam bv (bytevector-length bv)))))) (def (ffi-scintilla-receive-bytes handle msg wparam) (ensure-size 'ffi-scintilla-receive-bytes 'wparam wparam) @@ -421,9 +432,11 @@ (let ([key-bv (string->native-bytes 'ffi-scintilla-set-property 'key key)] [value-bv (string->native-bytes 'ffi-scintilla-set-property 'value value)]) (need-native 'ffi-scintilla-set-property) - (c-scintilla-set-property-bytes - handle msg key-bv (bytevector-length key-bv) - value-bv (bytevector-length value-bv)))) + (call-with-pinned-bytevectors (list key-bv value-bv) + (lambda () + (c-scintilla-set-property-bytes + handle msg key-bv (bytevector-length key-bv) + value-bv (bytevector-length value-bv)))))) (def (ffi-scintilla-get-property handle msg key) (let ([key-bv (string->native-bytes 'ffi-scintilla-get-property 'key key)]) @@ -477,7 +490,9 @@ (def (ffi-scintilla-set-lexer-language handle name) (let ([bv (string->native-bytes 'ffi-scintilla-set-lexer-language 'name name)]) (need-native 'ffi-scintilla-set-lexer-language) - (c-scintilla-set-lexer-language-bytes handle bv (bytevector-length bv)))) + (call-with-pinned-bytevectors (list bv) + (lambda () + (c-scintilla-set-lexer-language-bytes handle bv (bytevector-length bv)))))) (def (ffi-scintilla-drain-one handle) (need-native 'ffi-scintilla-drain-one) @@ -546,4 +561,6 @@ (def (ffi-tb-print-string x y fg bg str) (let ([bv (string->native-bytes 'ffi-tb-print-string 'str str)]) (need-native 'ffi-tb-print-string) - (c-tb-print-bytes x y fg bg bv (bytevector-length bv)))) + (call-with-pinned-bytevectors (list bv) + (lambda () + (c-tb-print-bytes x y fg bg bv (bytevector-length bv))))))