From b38983109b40ae7cf377b9b167254cd452c3cc74 Mon Sep 17 00:00:00 2001 From: Hans Dijkema Date: Mon, 29 Jun 2026 15:10:15 +0200 Subject: [PATCH] flac problems for os threads solved. --- flac-decoder.rkt | 15 +---- libflac-ffi.rkt | 127 ++++++++++++++++++++++++++++++------------- tests/flac-tests.rkt | 69 +++++++++++++++++++++++ tests/opus-tests.rkt | 46 ++++++++++++++++ 4 files changed, 206 insertions(+), 51 deletions(-) create mode 100644 tests/flac-tests.rkt create mode 100644 tests/opus-tests.rkt diff --git a/flac-decoder.rkt b/flac-decoder.rkt index f42de05..10a83d1 100644 --- a/flac-decoder.rkt +++ b/flac-decoder.rkt @@ -15,8 +15,6 @@ flac-stop flac-seek (all-from-out "flac-definitions.rkt") - kinds - last-buffer last-buf-len ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -42,24 +40,13 @@ (define (flac-stream-state handle) ((flac-handle-ffi-decoder-handler handle) 'state)) - - (define kinds (make-hash)) - (define last-buffer #f) - (define last-buf-len #f) - - - (define (process-frame handle h mem-out) + (define (process-frame handle h mem-out) (let* ([cb-audio (flac-handle-cb-audio handle)] [type (hash-ref h 'number-type)] [buf-size (bytes-length mem-out)]) (hash-set! h 'duration (flac-duration handle)) - (set! last-buffer mem-out) - (set! last-buf-len buf-size) - - (hash-set! kinds type #t) - (when (procedure? cb-audio) (cb-audio h mem-out buf-size)) diff --git a/libflac-ffi.rkt b/libflac-ffi.rkt index 16cc210..3dc1aac 100644 --- a/libflac-ffi.rkt +++ b/libflac-ffi.rkt @@ -380,27 +380,46 @@ ;; FLAC Callback function definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - +;; libFLAC keeps the C callback pointers that are passed to +;; FLAC__stream_decoder_init_file and calls them later from +;; FLAC__stream_decoder_process_single. When process_single runs in a +;; Racket thread with #:pool 'own, those callbacks can arrive from a +;; different OS thread than the ordinary Racket coroutine-thread OS +;; thread. Use #:async-apply so Racket can transfer such callback +;; invocations safely, and use a per-decoder #:keep box so the generated +;; callback stubs stay reachable as long as the decoder can call them. +(define (flac-callback-async-apply thunk) + (thunk)) + ;typedef FLAC__StreamDecoderWriteStatus(* FLAC__StreamDecoderWriteCallback) (const FLAC__StreamDecoder *decoder, const FLAC__Frame *frame, const FLAC__int32 *const buffer[], void *client_data) -(define _FLAC__StreamDecoderWriteCallback - (_fun _FLAC__StreamDecoder-pointer - _FLAC__Frame-pointer - FLAC__int32** - _FLAC__Data-pointer - -> _int)) +(define (make-FLAC__StreamDecoderWriteCallback keep-box) + (_cprocedure + (list _FLAC__StreamDecoder-pointer + _FLAC__Frame-pointer + FLAC__int32** + _FLAC__Data-pointer) + _int + #:async-apply flac-callback-async-apply + #:keep keep-box)) ;typedef void(* FLAC__StreamDecoderMetadataCallback) (const FLAC__StreamDecoder *decoder, const FLAC__StreamMetadata *metadata, void *client_data) -(define _FLAC__StreamDecoderMetadataCallback - (_fun _FLAC__StreamDecoder-pointer - _FLAC__StreamMetadata-pointer - _FLAC__Data-pointer - -> _void)) +(define (make-FLAC__StreamDecoderMetadataCallback keep-box) + (_cprocedure + (list _FLAC__StreamDecoder-pointer + _FLAC__StreamMetadata-pointer + _FLAC__Data-pointer) + _void + #:async-apply flac-callback-async-apply + #:keep keep-box)) -(define _FLAC__StreamDecoderErrorCallback - (_fun _FLAC__StreamDecoder-pointer - _int - _FLAC__Data-pointer - -> _void)) +(define (make-FLAC__StreamDecoderErrorCallback keep-box) + (_cprocedure + (list _FLAC__StreamDecoder-pointer + _int + _FLAC__Data-pointer) + _void + #:async-apply flac-callback-async-apply + #:keep keep-box)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -439,10 +458,10 @@ (define-libflac FLAC__stream_decoder_init_file (_fun _FLAC__StreamDecoder-pointer _string/utf-8 - _FLAC__StreamDecoderWriteCallback - _FLAC__StreamDecoderMetadataCallback - _FLAC__StreamDecoderErrorCallback - _FLAC__Data-pointer ; Seen by Jens Axel Søgaard - Is already present in FLAC 1.4.3 + _pointer + _pointer + _pointer + _FLAC__Data-pointer ; Seen by Jens Axel Søgaard - Is already present in FLAC 1.4.3 -> _int)) (define-libflac FLAC__stream_decoder_process_single @@ -524,26 +543,46 @@ (define fl #f) (define flac-file #f) (define client-data #f) - + (define callback-keepers (box null)) + + (define (make-decoder-callback proc type) + ;; Convert the Racket procedure to a C function pointer with a type + ;; that uses callback-keepers as #:keep. The raw pointer is passed to + ;; libFLAC, while the keeper box retains the generated callback stub + ;; until delete releases it after FLAC__stream_decoder_finish/delete. + (cast proc type _pointer)) + ;(define (write-callback fl frame buffer client-data) ; (set! write-data (append write-data (list (cons frame buffer)))) ; 0) (define (write-callback fl frame buffer client-data) - (set! write-data (cons (copy-flac-frame frame buffer) write-data)) - 0) + (with-handlers ([exn:fail? + (lambda (e) + ;; Never let a Racket exception escape through a C + ;; callback. Return FLAC__STREAM_DECODER_WRITE_STATUS_ABORT. + (set! error-no -2) + 1)]) + (set! write-data (cons (copy-flac-frame frame buffer) write-data)) + 0)) ;(define (meta-callback fl meta client-data) ; (let ((meta-clone (FLAC__metadata_object_clone meta))) ; (unless (eq? meta-clone #f) ; (set! meta-data (append meta-data (list meta-clone)))))) (define (meta-callback fl meta client-data) - (let ((meta-clone (FLAC__metadata_object_clone meta))) - (unless (eq? meta-clone #f) - (set! meta-data (cons meta-clone meta-data))))) + (with-handlers ([exn:fail? + (lambda (e) + ;; Metadata callbacks return void; remember failure and + ;; let the decoder state/error path report it. + (set! error-no -3) + (void))]) + (let ((meta-clone (FLAC__metadata_object_clone meta))) + (unless (eq? meta-clone #f) + (set! meta-data (cons meta-clone meta-data)))))) (define (error-callback fl errno client-data) (set! error-no errno) - ) + (void)) (define (new) (dbg-sound "flac-ffi 'new") @@ -554,13 +593,25 @@ (define (init file) (dbg-sound "flac-ffi 'init") - (let ((r (FLAC__stream_decoder_init_file - fl - file - write-callback - meta-callback - error-callback - client-data))) + (let* ((write-callback-ptr + (make-decoder-callback + write-callback + (make-FLAC__StreamDecoderWriteCallback callback-keepers))) + (meta-callback-ptr + (make-decoder-callback + meta-callback + (make-FLAC__StreamDecoderMetadataCallback callback-keepers))) + (error-callback-ptr + (make-decoder-callback + error-callback + (make-FLAC__StreamDecoderErrorCallback callback-keepers))) + (r (FLAC__stream_decoder_init_file + fl + file + write-callback-ptr + meta-callback-ptr + error-callback-ptr + client-data))) (set! flac-file file) r)) @@ -571,8 +622,10 @@ (begin (FLAC__stream_decoder_finish fl) (FLAC__stream_decoder_delete fl) - (set! fl #f))) - ) + (set! fl #f) + ;; libFLAC cannot call the callbacks anymore after finish/delete, + ;; so the generated callback stubs can now be released. + (set-box! callback-keepers null)))) (define (process-single) (FLAC__stream_decoder_process_single fl)) diff --git a/tests/flac-tests.rkt b/tests/flac-tests.rkt new file mode 100644 index 0000000..72d2878 --- /dev/null +++ b/tests/flac-tests.rkt @@ -0,0 +1,69 @@ +#lang racket/base + +(require "../flac-decoder.rkt") + +(define (test-flac-thread flac-path #:pool [pool #f]) + (define result-ch (make-channel)) + + (define (start) + (thread + (lambda () + (with-handlers ([exn:fail? + (lambda (e) + (channel-put result-ch + (list 'error (exn-message e))))]) + (define frames 0) + (define buffers 0) + (define bytes 0) + (define fmt #f) + + (define h + (flac-open + flac-path + + ;; stream-info callback + (lambda (info) + (set! fmt info) + (printf "format: ~s\n" info) + (flush-output)) + + ;; audio callback + (lambda (info buffer len) + (set! buffers (add1 buffers)) + (set! bytes (+ bytes len)) + (define blocksize (hash-ref info 'blocksize #f)) + (when (integer? blocksize) + (set! frames (+ frames blocksize))) + + ;; af en toe iets printen, zodat je ziet dat hij loopt + (when (zero? (modulo buffers 500)) + (printf "buffers=~a bytes=~a frames=~a\n" + buffers bytes frames) + (flush-output))))) + + (unless h + (error 'test-flac-thread "could not open FLAC file: ~a" flac-path)) + + (define state (flac-read h)) + + (channel-put result-ch + (list 'ok + 'state state + 'buffers buffers + 'bytes bytes + 'frames frames + 'format fmt)))) + #:pool pool) + ) + + (start) + (start) + (start) + + (channel-get result-ch) + (channel-get result-ch) + (channel-get result-ch) + ) + + +; (test-flac-thread "\\\\panderleou\\music\\Jazz\\LA4\\LA4 - Zaca\\01 Zaca.flac") \ No newline at end of file diff --git a/tests/opus-tests.rkt b/tests/opus-tests.rkt new file mode 100644 index 0000000..6d3cfeb --- /dev/null +++ b/tests/opus-tests.rkt @@ -0,0 +1,46 @@ +#lang racket/base + +(require "../main.rkt" + "../audio-encoder.rkt") + + +(define (convert-to-opus flac-in opus-out) + (let* ((opus-kbps 224) + (settings (hash 'bitrate (* opus-kbps 1000) + 'vbr #t)) + ) + (with-handlers ([exn? (λ (e) + (displayln (format "~a" e)) + (when (file-exists? opus-out) + (delete-file opus-out)) + #f)]) + (let ((result (audio-encode flac-in opus-out + settings + #:encoder 'opus + #:copy-tags? #t))) + #t) + ) + ) + ) + +(define (times-3-convert flac-in opus-out1 opus-out2 opus-out3 #:pool [pool #f]) + (define (start opus-out) + (thread (λ () + (displayln (format "Starting conversion: ~a" opus-out)) + (convert-to-opus flac-in opus-out) + (displayln (format" converted: ~a" opus-out)) + #t + ) #:pool pool) + ) + + (let* ((t1 (start opus-out1)) + (t2 (start opus-out2)) + (t3 (start opus-out3)) + ) + (thread-wait t1) + (thread-wait t2) + (thread-wait t3) + ) + ) + +; (convert-to-opus "\\\\panderleou\\music\\Jazz\\LA4\\LA4 - Zaca\\01 Zaca.flac" "c:\\tmp\\test.opus" ) \ No newline at end of file