alsa-dispatcher.lsp

   1 ;; This is the main script for the pcm-dispatch tool
   2 ;; last main-arg nominates the configuration file
   3
   4 ; ############################################################
   5 ; misc API
   6 (signal 1 (fn (x) (exit 0)))
   7 (signal 2 (fn (x) (exit 0)))
   8 (signal 15 (fn (x) (exit 0)))
   9
  10 (define (die N)
  11   (when (args) (write-line 2 (join (map string (args)) " ")))
  12   (when (number? N) (exit N)))
  13
  14 (define (enlist X) (if (list? X) X (list X)))
  15
  16 (define (comment? LINE) (and (regex "^\\s*(#|$)" LINE 0) true))
  17
  18 (define (first-word LINE) (and (regex "^\\s*(\\S+)" LINE 0) $1))
  19
  20 (define (prog1 X) X)
  21
  22 (define (read-config-line LINE)
  23   (map (fn (x) (if (regex "^([^=]+)=(.*)" x) (list $1 $2) x))
  24        (map trim (find-all "([^, ]+)" LINE $1 0))))
  25
  26 ;; ############################################################
  27 ;; Load Configuration (~/.alsa-dispatcher)
  28 ; Format: one-liners for each option, ignoring comment lines starting
  29 ; with # and blank lines.
  30 (constant
  31  'HOME (env "HOME")
  32  'CONFIG (format "%s/.alsa-dispatcher" HOME)
  33  'CFGLINES (if (read-file CONFIG) (clean comment? (parse $it "\n" ))
  34              '("bt,latency=1000" "plughw"))
  35  'CFGMAP (map read-config-line CFGLINES)
  36  'PCM-LIST (map first-word CFGLINES)
  37  )
  38
  39 (define (cfg-lookup PCM KEY DEFAULT)
  40   (if (if (assoc PCM CFGMAP) (lookup KEY $it)) (read-expr $it) DEFAULT))
  41
  42 ; ############################################################
  43 ; libc API
  44 (constant 'libc.so.6 "/lib/x86_64-linux-gnu/libc.so.6")
  45 ; https://www.gnu.org/software/libc/manual/html_mono/libc.html
  46
  47 ;; (dup2 OLDFD NEWFD) - Duplicate file descriptor OLDFD onto NEWFD,
  48 ;; closing the latter first if open.
  49 (import libc.so.6 "dup2" "int"
  50         "int" ; int oldfd
  51         "int" ; int newfd
  52         )
  53
  54 ; ############################################################
  55 ; libasound API
  56 (constant 'libasound.so "/usr/lib/x86_64-linux-gnu/libasound.so")
  57 ; https://www.alsa-project.org/alsa-doc/alsa-lib/
  58 ; /usr/include/asm-generic/errno-base.h
  59
  60 ;; Used constants
  61 (constant
  62  'SND_PCM_STREAM_PLAYBACK 0
  63  'SND_PCM_MODE_BLOCK 0 ; this mode label is invented here
  64  'SND_PCM_FORMAT_S16_LE 2
  65  'SND_PCM_ACCESS_RW_INTERLEAVED 3
  66  )
  67
  68 ;; (snd_pcm_close PCM) - Close PCM handle. Closes the given PCM handle
  69 ;; and frees all associated resources. (The PCM reference is probably
  70 ;; "invalid" after closing)
  71 (import libasound.so "snd_pcm_close" "int"
  72         "void*" ; snd_pcm_t *pcm
  73         )
  74
  75 ;; (snd_pcm_drain PCM) - Stop PCM whilst preserving pending frames.
  76 ;; For playback wait for all pending frames to be played and then stop
  77 ;; the PCM. For capture stop PCM permitting to retrieve residual
  78 ;; frames.
  79 (import libasound.so "snd_pcm_drain" "int"
  80         "void*" ; snd_pcm_t *pcm
  81         )
  82
  83 ;; (snd_pcm_open NAME STREAM MODE) - Opens a PCM and returns its
  84 ;; handle or nil. Actual error code is discarded.
  85 (letex ((IMP (import libasound.so "snd_pcm_open" "int"
  86                      "void*" ; snd_pcm_t **pcmp [output]
  87                      "char*" ; const char *name
  88                      "int"   ; snd_pcm_stream_t stream
  89                      "int"   ; int mode
  90                      )))
  91   (constant 'snd_pcm_open ; redefine the symbol to wrap the import
  92    (fn (NAME STREAM MODE)
  93      (let ((PCM (pack "Lu" 0)))
  94        (when (= (IMP PCM NAME STREAM MODE)) ((unpack "Lu" PCM) 0))))))
  95
  96 ;; (snd_pcm_set_params PCM FMT ACCESS CH RATE RESAMPLE LATENCY) - Set
  97 ;; the hardware and software parameters in a simple way.
  98 (import libasound.so "snd_pcm_set_params" "int"
  99         "void*" ; snd_pcm_t *pcm
 100         "int"   ; snd_pcm_format_t format
 101         "int"   ; snd_pcm_access_t access
 102         "unsigned int" ; unsigned int channels
 103         "unsigned int" ; unsigned int rate
 104         "int"   ;int soft_resample
 105         "unsigned int" ; unsigned int latency
 106         )
 107
 108 ;; (snd_pcm_wait PCM TIMEOUT) - Wait for a PCM to become ready.
 109 ;; Returns a positive value on success otherwise a negative error code
 110 ;; (-EPIPE [-32] for the xrun and -ESTRPIPE [-86] for the suspended
 111 ;; status, others for general errors)
 112 (import libasound.so "snd_pcm_wait" "int"
 113         "void*" ; snd_pcm_t *pcm
 114         "int"   ; int timeout
 115         )
 116
 117 ;; (snd_pcm_writei PCM BUFFER FRAMES) - Write interleaved frames to a
 118 ;; PCM. If the blocking behaviour is selected and the PCM is running,
 119 ;; then routine waits until all requested frames are played or put to
 120 ;; the playback ring buffer. The returned number of frames can be less
 121 ;; only if a signal or underrun occurred.
 122 (import libasound.so "snd_pcm_writei" "long" ; snd_pcm_uframes_t
 123         "void*" ; snd_pcm_t *pcm
 124         "void*" ; const void *buffer
 125         "long"   ; snd_pcm_uframes_t size
 126         )
 127
 128 ;; Open a PCM by name
 129 (define (open-pcm NAME)
 130   (snd_pcm_open NAME SND_PCM_STREAM_PLAYBACK SND_PCM_MODE_BLOCK))
 131
 132 ;; Setup PCM
 133 (define (setup-pcm PCM)
 134   (snd_pcm_set_params PCM
 135                       (cfg-lookup PCM "format" SND_PCM_FORMAT_S16_LE)
 136                       SND_PCM_ACCESS_RW_INTERLEAVED
 137                       (cfg-lookup PCM "channels" 2)
 138                       (cfg-lookup PCM "rate" 48000)
 139                       1 ; soft resample (0/1)
 140                       (cfg-lookup PCM "latency" 100000) ; (microseconds)
 141                       ))
 142
 143 ;; ############################################################
 144 ; The main program
 145
 146 ;; redirect stdout/err to /dev/null
 147 (when nil
 148   (let ((REDIR (open "/dev/null" "append")))
 149     (when (< REDIR) (exit 1))
 150     (when (< (libc:dup2 REDIR 2)) (exit 1))
 151     (when (< (libc:dup2 REDIR 1)) (exit 1))
 152     (close REDIR)
 153   ))
 154
 155 ; find the first usable PCM
 156 (setf PCM (unless (dolist (NAME PCM-LIST (open-pcm NAME)))
 157             (die 1 "No PCM available")))
 158
 159 ; configure the PCM
 160 (when (!= (setf E (setup-pcm PCM)))
 161   (snd_pcm_close PCM)
 162   (die 1 "set params" E))
 163
 164 (setf N 0 x 0 E 0 i 0)
 165
 166 (setf CACHE nil)
 167 (while (> (or (setf N (read 0 BUFFER 20000000)) 0))
 168   ;(println "reading " N)
 169   (setf CACHE BUFFER)
 170   (while (> N)
 171     ;;(ready PCM)
 172     (when (< (setf E (snd_pcm_writei PCM CACHE (/ N 4))))
 173       (snd_pcm_close PCM)
 174       (die 1 "writing" E N))
 175     (setf E (* E 4))
 176     (setf CACHE (E CACHE))
 177     ;(println "wrote " E)
 178     (dec N E)
 179     )
 180   )
 181
 182 (snd_pcm_wait PCM -1)
 183 (snd_pcm_drain PCM)
 184 (snd_pcm_close PCM)
 185 (exit 0)