#lang racket/base ;; Pure Racket replacement for ao_playasync.c as used by libao.rkt. ;; ;; This module exports the same Racket API as libao-async-ffi.rkt, but it ;; calls Xiph libao directly and uses a Racket worker thread instead of the ;; C queue/thread backend. (define AO-ASYNC-VERSION 3) (require ffi/unsafe ffi/unsafe/define ffi/unsafe/custodian racket/async-channel data/queue racket/list "private/utils.rkt") (provide ao_version_async ao_create_async ao_real_output_bits_async ao_stop_async ao_play_async ao_is_at_music_id_async ao_is_at_second_async ao_music_duration_async ao_bufsize_async ao_clear_async ao_pause_async ao_set_volume_async ao_volume_async ao_reuse_buf_len make-buffer-info make-BufferInfo_t ) ;; ------------------------------------------------------------------------- ;; Public structs and enums: keep these equal to the old FFI module. (define _Endian_t (_enum '(little-endian = 1 big-endian = 2 native-endian = 4))) (define-struct buffer-info (type ; 'interleaved (old: 'ao) or 'planar (old: 'flac) sample-bits sample-rate channels endianness ) #:mutable #:transparent ) (define make-BufferInfo_t make-buffer-info) ;; ------------------------------------------------------------------------- ;; Direct libao FFI. (define libao (get-lib (list (case (system-type 'os) [(windows) "libao-1.2.2"] [else "libao"])) '(#f))) (define-ffi-definer define-ao libao) (define _ao-device (_cpointer/null 'ao-device)) (define _ao-option (_cpointer/null 'ao-option)) (define-cstruct _ao_sample_format ([bits _int] [rate _int] [channels _int] [byte_format _Endian_t] [matrix _string*/utf-8])) (define-ao ao_initialize (_fun -> _void)) (define-ao ao_shutdown (_fun -> _void)) (define-ao ao_default_driver_id (_fun -> _int)) (define-ao ao_driver_id (_fun _string/utf-8 -> _int)) (define-ao ao_open_live (_fun _int _ao_sample_format-pointer _ao-option -> _ao-device)) (define-ao ao_open_file (_fun _int _string/utf-8 _int _ao_sample_format-pointer _ao-option -> _ao-device)) (define-ao ao_close (_fun _ao-device -> _int)) ;; ao_play can block until the device accepts more data. Mark it as blocking ;; so other Racket places/threads are not needlessly held up by the foreign ;; call. This is the important part that makes the C backend much less useful. (define-ao ao_play (_fun #:blocking? #t _ao-device _pointer _uint32 -> _int)) ;(_fun _ao-device _pointer _uint32 -> _int)) ;(_fun #:blocking? #t _ao-device _bytes _uint32 -> _int)) ;; ------------------------------------------------------------------------- ;; Mutex stuff ;; ------------------------------------------------------------------------- (define (make-mutex) (let ((sem (make-semaphore))) (semaphore-post sem) sem)) (define (mutex-lock sem) (semaphore-wait sem)) (define (mutex-unlock sem) (semaphore-post sem)) ;; ------------------------------------------------------------------------- ;; Async handle etc. ;; ------------------------------------------------------------------------- (define (command? x) (or (eq? x 'play) (eq? x 'stop))) (define-struct queue-elem (command buf buflen at-second music-duration music-id ) #:mutable ) (define-struct ao-handle (queue paused ao-device requested-bits-per-sample dev-bits-per-sample dev-endianness dev-channels dev-rate mutex pause-mutex clear-mutex buf-mutex add-mutex play-thread at-second music-duration music-id buf-size volume-in-10000 valid bufs current-elem bytes-left ) #:mutable ) (define ao-buf-ms 50) ;; Playback buffer of 0.5s (define (get h ms-wait) (let ((el (if (<= ms-wait 0) (sync/timeout 0 (ao-handle-queue h)) (sync/timeout (/ ms-wait 1000.0) (ao-handle-queue h) )))) (unless (eq? el #f) (set-ao-handle-buf-size! h (- (ao-handle-buf-size h) (queue-elem-buflen el)))) el)) (define (needed-bytes h) (let ((req-bytes (/ (ao-handle-dev-bits-per-sample h) 8)) (rate-s (ao-handle-dev-rate h)) (channels (ao-handle-dev-channels h)) ) (/ (* req-bytes rate-s channels ao-buf-ms) 1000) ) ) (define (bytes->samples h s) (let ((req-bytes (/ (ao-handle-dev-bits-per-sample h) 8)) (rate-s (ao-handle-dev-rate h)) (channels (ao-handle-dev-channels h))) (/ s req-bytes channels))) (define (add h elem) (mutex-lock (ao-handle-add-mutex h)) (add* h elem) (mutex-unlock (ao-handle-add-mutex h)) ) (define (add* h elem) (if (eq? (queue-elem-command elem) 'stop) (begin (unless (eq? (ao-handle-current-elem h) #f) (async-channel-put (ao-handle-queue h) (ao-handle-current-elem h)) (set-ao-handle-current-elem! h #f)) (async-channel-put (ao-handle-queue h) elem) ) (let* ((cb (ao-handle-current-elem h))) (if (eq? cb #f) (begin (set-ao-handle-current-elem! h elem) (set! cb elem) (let* ((ns (needed-bytes h)) (new-buf (cadr (alloc-buf h ns)))) (memcpy new-buf (queue-elem-buf cb) (queue-elem-buflen cb)) ;(dbg-sound "Allocated new buffer of ~a bytes (~a samples) for elem size ~a" ns (bytes->samples h ns) (queue-elem-buflen cb)) (reuse-buf h (queue-elem-buf cb)) (set-queue-elem-buf! cb new-buf) (set-ao-handle-bytes-left! h (- ns (queue-elem-buflen cb))) (set-ao-handle-buf-size! h (+ (ao-handle-buf-size h) (queue-elem-buflen elem))) )) (if (or (not (equal? (queue-elem-music-id cb) (queue-elem-music-id elem))) (< (- (ao-handle-bytes-left h) (queue-elem-buflen elem)) 0)) (begin ; push this buffer and restart ;(dbg-sound "Pushing sound buffer with ~a samples left" (ao-handle-bytes-left h)) (async-channel-put (ao-handle-queue h) cb) (set-ao-handle-current-elem! h #f) (add* h elem)) (let ((offset (queue-elem-buflen cb))) (memcpy (queue-elem-buf cb) offset (queue-elem-buf elem) (queue-elem-buflen elem)) (set-queue-elem-buflen! cb (+ offset (queue-elem-buflen elem))) (set-ao-handle-bytes-left! h (- (ao-handle-bytes-left h) (queue-elem-buflen elem))) (set-ao-handle-buf-size! h (+ (ao-handle-buf-size h) (queue-elem-buflen elem))) (reuse-buf h (queue-elem-buf elem)) (when (= (ao-handle-bytes-left h) 0) (async-channel-put (ao-handle-queue h) cb) (set-ao-handle-current-elem! h #f)) ) ) ) ) ) ) (define (new-elem h command music-id at-second music-duration buflen buf) ;(let ((new-buf (make-bytes buflen))) ;((new-buf (malloc buflen 'atomic))) ; (memcpy new-buf buf buflen) ;(make-queue-elem command new-buf buflen at-second music-duration music-id))) (make-queue-elem command buf buflen at-second music-duration music-id)) (define (del-elem h elem) (reuse-buf h (queue-elem-buf elem)) ; does nothing #t) (define (clear h) (let ((count 0)) (mutex-lock (ao-handle-clear-mutex h)) (let ((el (get h 0))) ; Clear the elements in the queue (while (not (eq? el #f)) (del-elem h el) (set! count (+ count 1)) (set! el (get h 0))) ; Clear the current element in processing (mutex-lock (ao-handle-add-mutex h)) (unless (eq? (ao-handle-current-elem h) #f) (let* ((ce (ao-handle-current-elem h)) (cb (queue-elem-buf ce))) (unless (eq? cb #f) (reuse-buf h cb)))) (set-ao-handle-current-elem! h #f) (set-ao-handle-bytes-left! h 0) (set-ao-handle-buf-size! h 0) (mutex-unlock (ao-handle-add-mutex h)) (mutex-unlock (ao-handle-clear-mutex h)) (dbg-sound "~a elements cleared" count) ) ) ) (define-syntax system-little-endian? (syntax-rules () ((_) (not (system-big-endian?))))) (define (is-little-endian? e) (cond [(eq? e 'little-endian) #t] [(eq? e 'big-endian) #f] [(eq? e 'native-endian) (system-little-endian?)] [else (error 'convert-bits "unknown endian value: ~a" e)])) (define (is-big-endian? e) (not (is-little-endian? e))) (define (endian-eq? a b) (let ((le-a (is-little-endian? a)) (le-b (is-little-endian? b))) (eq? le-a le-b))) (define (alloc-buf h size) (let ((entry #f)) (letrec ((f (λ (entries min-size min-size-idx idx) (if (null? entries) min-size-idx (let ((e (car entries))) (if (<= size (car e)) (if (or (eq? min-size #f) (< (car e) min-size)) (f (cdr entries) (car e) idx (+ idx 1)) (f (cdr entries) min-size min-size-idx (+ idx 1)) ) (f (cdr entries) min-size min-size-idx (+ idx 1)) ) ) ) ) )) (mutex-lock (ao-handle-buf-mutex h)) (let ((bufs (ao-handle-bufs h)) (entry #f)) (unless (null? bufs) (let ((idx (f bufs #f #f 0))) (unless (eq? idx #f) (let ((e (list-ref bufs idx))) ;(dbg-sound "Reusing index ~a, ~a for size ~a" idx (car e) size) (set! entry (list-ref bufs idx)) (set-ao-handle-bufs! h (append (take bufs idx) (drop bufs (+ idx 1)))) ) ) ) ) (mutex-unlock (ao-handle-buf-mutex h)) ;(dbg-sound "Alloc buf: ~a, got ~a" size (map (λ (e) (car e)) (ao-handle-bufs h))) (if (eq? entry #f) (list size (make-bytes size)) entry) ) ) ) ) (define (reuse-buf h buf) (unless (eq? buf #f) (mutex-lock (ao-handle-buf-mutex h)) (set-ao-handle-bufs! h (cons (list (bytes-length buf) buf) (ao-handle-bufs h))) (when (> (length (ao-handle-bufs h)) 10) (set-ao-handle-bufs! h (take (ao-handle-bufs h) 5))) (mutex-unlock (ao-handle-buf-mutex h)) ) #t ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Converters ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Volume (define (adjust-volume h bs buf-size volume-in-10000) ;; bs: bytes ;; buf-size: aantal geldige bytes in bs (let* ([bits (ao-handle-dev-bits-per-sample h)] [bytes-per-sample (arithmetic-shift bits -3)] [big? (is-big-endian? (ao-handle-dev-endianness h))]) (unless (= volume-in-10000 10000) (for ([i (in-range 0 buf-size bytes-per-sample)]) (let* ([sample (int-bytes->integer bs #t big? i (+ i bytes-per-sample))] [scaled (quotient (* sample volume-in-10000) 10000)]) (integer->int-bytes scaled bytes-per-sample #t big? bs i)))) #t)) ;;; planar -> intereleaved (define (planar-to-interleaved h mem buf-size info) ;; mem: bytes ;; result: (list bytes output-size) (let* ([type (buffer-info-type info)] [bits (buffer-info-sample-bits info)] [channels (buffer-info-channels info)] [bytes (arithmetic-shift bits -3)] [out-size buf-size] [out (cadr (alloc-buf h out-size))] ) (unless (or (eq? type 'planar) (eq? type 'flac)) (error (format "expected planar buffer, got: ~a" type))) (unless (zero? (remainder buf-size (* channels bytes))) (error (format "buffer size ~a is not aligned to ~a channels of ~a-bit samples" buf-size channels bits))) (let* ([samples-total (quotient buf-size bytes)] [samples-per-channel (quotient samples-total channels)] [plane-size (* samples-per-channel bytes)]) (for ([sample-index (in-range samples-per-channel)]) (for ([channel (in-range channels)]) (let* ([in-pos (+ (* channel plane-size) (* sample-index bytes))] [out-pos (* (+ (* sample-index channels) channel) bytes)]) (bytes-copy! out out-pos mem in-pos (+ in-pos bytes))))) (list out out-size)))) ;;; requested bits to device bits (define (convert-bits h buf buf-size in-bits in-endianness out-bits out-endianness) ;; buf: bytes ;; returns: (list out-bytes out-size) (let* ([in-bytes (arithmetic-shift in-bits -3)] [out-bytes (arithmetic-shift out-bits -3)] [samples (quotient buf-size in-bytes)] [out-size (* samples out-bytes)] [out (cadr (alloc-buf h out-size))] [shift (- out-bits in-bits)] [in-big? (is-big-endian? in-endianness)] [out-big? (is-big-endian? out-endianness)]) (for ([n (in-range samples)]) (let* ([in-pos (* n in-bytes)] [out-pos (* n out-bytes)] [sample (int-bytes->integer buf #t in-big? in-pos (+ in-pos in-bytes))] [converted (arithmetic-shift sample shift)]) (integer->int-bytes converted out-bytes #t out-big? out out-pos))) (list out out-size #t))) (define (convert-req-bits-to-dev-bits h mem buf-size info) (if (and (= (buffer-info-sample-bits info) (ao-handle-dev-bits-per-sample h)) (endian-eq? (buffer-info-endianness info) (ao-handle-dev-endianness h))) (list mem buf-size #f) (convert-bits h mem buf-size (buffer-info-sample-bits info) (buffer-info-endianness info) (ao-handle-dev-bits-per-sample h) (ao-handle-dev-endianness h) ) ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ASync player ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (run h) (thread (λ () (let ((go-on #t) (buf #f) (buf-size 0)) (while go-on (mutex-lock (ao-handle-pause-mutex h)) (mutex-unlock (ao-handle-pause-mutex h)) (mutex-lock (ao-handle-clear-mutex h)) (let ((elem (get h 250))) (mutex-unlock (ao-handle-clear-mutex h)) (if (eq? elem #f) (begin (dbg-sound "nothing in the queue") (sleep 0.005)) (begin (if (eq? (queue-elem-command elem) 'stop) (set! go-on #f) (begin (set-ao-handle-at-second! h (queue-elem-at-second elem)) (set-ao-handle-music-duration! h (queue-elem-music-duration elem)) (set-ao-handle-music-id! h (queue-elem-music-id elem)) (unless (= (ao-handle-volume-in-10000 h) 10000) (adjust-volume h (queue-elem-buf elem) (queue-elem-buflen elem) (ao-handle-volume-in-10000 h))) (let* ((size (queue-elem-buflen elem))) (when (> size buf-size) (set! buf (malloc size 'atomic-interior )) (set! buf-size size)) (memcpy buf (queue-elem-buf elem) size) (ao_play (ao-handle-ao-device h) buf size) ) ) ) (del-elem h elem) ) ) ) ) ) ) #:pool 'own ) ) (define handle-admin-mutex (make-mutex)) (define num-of-handles 0) (register-finalizer-and-custodian-shutdown num-of-handles (λ (v) (unless (= num-of-handles 0) (ao_shutdown))) #:at-exit? #t ) (define (dec-ao-handles) (mutex-lock handle-admin-mutex) (set! num-of-handles (- num-of-handles 1)) (when (= num-of-handles 0) (ao_shutdown) (dbg-sound "ao_shutdown executed") ) (mutex-unlock handle-admin-mutex) ) (define (inc-ao-handles) (mutex-lock handle-admin-mutex) (when (= num-of-handles 0) (ao_initialize) (dbg-sound "ao_initialized executed") ) (set! num-of-handles (+ num-of-handles 1)) (mutex-unlock handle-admin-mutex) ) (define (ao_close* ao_ffi_handle) (ao_close ao_ffi_handle) (dec-ao-handles)) (define (ao_open_live* driver-id fmt matrix) (inc-ao-handles) (let ((r (ao_open_live driver-id fmt matrix))) (when (eq? r #f) (dec-ao-handles)) r)) (define (ao_open_file* driver-id file x fmt matrix) (inc-ao-handles) (let ((r (ao_open_file driver-id file x fmt matrix))) (when (eq? r #f) (dec-ao-handles)) r)) (define (ao_default_driver_id*) (inc-ao-handles) (let ((r (ao_default_driver_id))) (dec-ao-handles) r)) (define (try-open-device bits rate channels byte-format wav-output-file) (let ((candidates (make-vector 3 bits)) (n 1) (result #f)) (when (> bits 24) (vector-set! candidates n 24) (set! n (+ n 1))) (when (> bits 16) (vector-set! candidates n 16) (set! n (+ n 1))) (let ((i 0)) (while (< i n) (let* ((fmt (make-ao_sample_format (vector-ref candidates i) rate channels byte-format #f)) (driver-id (if (eq? wav-output-file #f) (ao_default_driver_id*) (ao_driver_id "wav"))) (dev (if (eq? wav-output-file #f) (ao_open_live* driver-id fmt #f) (ao_open_file* driver-id wav-output-file 1 fmt #f))) ) (unless (eq? dev #f) (set! result (list dev (vector-ref candidates i))) (set! i n) ) ) (set! i (+ i 1)) ) ) (if (eq? result #f) (list #f 0) result) ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; API ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (ao_version_async) AO-ASYNC-VERSION) (define (ao_create_async bits rate channels byte-format wav-output-file) (let ((handle (make-ao-handle (make-async-channel) ; queue #f ; paused #f ; ao-device bits ; requested-bits-per-sample 0 ; device bits per sample 'little-endian ; dev-endianness channels ; dev-channels rate ; dev-rate (make-mutex) ; mutex (make-mutex) ; pause-mutex (make-mutex) ; clear-mutex (make-mutex) ; buf-mutex (make-mutex) ; add-mutex #f ; play-thread 0.0 ; at-second 0.0 ; music-duration 0 ; music-id 0 ; total buf size 10000 ; volume-in-10000 #t ; valid handle '() ; reuse buffer #f ; current element 0 ; bytes left ))) (let ((ao-dev-bits (try-open-device bits rate channels byte-format wav-output-file))) (set-ao-handle-ao-device! handle (car ao-dev-bits)) (set-ao-handle-dev-bits-per-sample! handle (cadr ao-dev-bits)) (if (eq? (car ao-dev-bits) #f) (begin (err-sound "Cannot open ao-device") #f) (begin (set-ao-handle-play-thread! handle (run handle)) (register-finalizer handle (λ (v) (when (ao-handle-valid v) ao_stop_async v))) handle) ) ) ) ) (define (ao_stop_async h) (unless (ao-handle-valid h) (error "Not a valid ao handle")) (dbg-sound "Stopping ao-async, calling clear") (clear h) (dbg-sound "Queue cleared") (when (ao-handle-paused h) (mutex-unlock (ao-handle-pause-mutex h))) (let ((elem (new-elem h 'stop 0 0.0 0.0 0 #f))) (add h elem)) (dbg-sound "Stop command queued") (thread-wait (ao-handle-play-thread h)) (dbg-sound "Play thread stopped") (ao_close* (ao-handle-ao-device h)) (dbg-sound "AO Device closed") (set-ao-handle-valid! h #f) h ) (define (ao_play_async h music-id at-second music-duration buf-size mem info) (let ((type (buffer-info-type info))) (unless (bytes? mem) (error "ao_play_async: paramater mem must be of type bytes")) (when (or (eq? type 'planar) (eq? type 'flac)) (dbg-sound "Converting from planar to interleaved") (let ((m (planar-to-interleaved h mem buf-size info))) (reuse-buf h mem) (set! mem (car m)) (set! buf-size (cadr m))) ) (let ((ao-size buf-size) (ao-mem mem)) (let ((m (convert-req-bits-to-dev-bits h mem buf-size info))) (when (eq? (caddr m) #t) (reuse-buf h mem) (set! ao-mem (car m)) (set! ao-size (cadr m)))) (unless (bytes? ao-mem) (error "Hey! this was unexpected!")) (let ((elem (new-elem h 'play music-id at-second music-duration ao-size ao-mem))) (add h elem)) ) ) ) (define (ao_clear_async h) (clear h)) (define (ao_is_at_second_async h) (ao-handle-at-second h)) (define (ao_is_at_music_id_async h) (ao-handle-music-id h)) (define (ao_music_duration_async h) (ao-handle-music-duration h)) (define (ao_bufsize_async h) (ao-handle-buf-size h)) (define (ao_set_volume_async h percentage) (let ((volume-10000 (inexact->exact (round (* percentage 100.0))))) (when (and (> volume-10000 9990) (< volume-10000 10010)) (set! volume-10000 10000)) (set-ao-handle-volume-in-10000! h volume-10000) ) ) (define (ao_volume_async h) (let ((volume-10000 (ao-handle-volume-in-10000 h))) (/ volume-10000 100.0) ) ) (define (ao_pause_async h paused) (if (ao-handle-paused h) (when (eq? paused #f) (mutex-unlock (ao-handle-pause-mutex h)) (set-ao-handle-paused! h #f) ) (when (eq? paused #t) (mutex-lock (ao-handle-pause-mutex h)) (set-ao-handle-paused! h #t) ) ) ) (define (ao_real_output_bits_async h) (ao-handle-dev-bits-per-sample h)) (define (ao_reuse_buf_len h) (length (ao-handle-bufs h)))