Author: wmb
Date: 2010-01-07 09:04:00 +0100 (Thu, 07 Jan 2010)
New Revision: 1647
Added:
dev/hdaudio/noiseburst.fth
Modified:
dev/geode/ac97/selftest.fth
dev/hdaudio/conexant.fth
dev/hdaudio/core.fth
Log:
HD Audio - improvements to core HD Audio code and preliminary checkin of
noise burst selftest code. That latter needs to be integrated properly.
Modified: dev/geode/ac97/selftest.fth
===================================================================
--- dev/geode/ac97/selftest.fth 2010-01-05 23:22:48 UTC (rev 1646)
+++ dev/geode/ac97/selftest.fth 2010-01-07 08:04:00 UTC (rev 1647)
@@ -45,6 +45,8 @@
/cycle +
;
+\ This version puts the tone first into the left channel for
+\ half the time, then into the right channel for the remainder
: make-tone ( freq -- )
sample-rate to fs ( freq ) set-freq
@@ -64,6 +66,21 @@
/cycle +loop
;
+\ This version puts the tone into both channels simultaneously
+: make-tone2 ( freq -- )
+ sample-rate to fs ( freq ) set-freq
+
+ record-base make-cycle drop
+
+ \ Duplicate left into right in the template
+ record-base #cycle /l* bounds ?do i w@ i wa1+ w! /l +loop
+
+ \ Replicate the template
+ record-base /cycle + record-len /cycle - bounds ?do
+ record-base i /cycle move
+ /cycle +loop
+;
+
: tone ( freq -- )
record-len la1+ " dma-alloc" $call-parent to record-base
make-tone
Modified: dev/hdaudio/conexant.fth
===================================================================
--- dev/hdaudio/conexant.fth 2010-01-05 23:22:48 UTC (rev 1646)
+++ dev/hdaudio/conexant.fth 2010-01-07 08:04:00 UTC (rev 1647)
@@ -4,51 +4,67 @@
\ \ Conexant
-: power-on ( -- ) h# 70500 cmd ;
-: power-off ( -- ) h# 70503 cmd ;
+: power-on ( -- ) h# 70500 cmd ; \ Set power state - on
+: power-off ( -- ) h# 70503 cmd ; \ Set power state - off
: power-on-all ( -- )
" "(01 10 11 12 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f 20 21 22 23 24)"
bounds do i c@ to node power-on loop
-;
+;
+: set-node ( node-id -- ) to node ;
+
+: afg ( -- ) 1 set-node ; \ Audio Function Group
+: dac1 ( -- ) h# 10 set-node ;
+: adc1 ( -- ) h# 14 set-node ;
+: mux ( -- ) h# 17 set-node ; \ mux between port b and port c
+: mux2 ( -- ) h# 18 set-node ;
+: porta ( -- ) h# 19 set-node ;
+: portb ( -- ) h# 1a set-node ; \ Port B - OLPC external mic
+: portc ( -- ) h# 1b set-node ; \ Port C - OLPC internal mic
+: portd ( -- ) h# 1c set-node ; \ Port D - OLPC unused
+: porte ( -- ) h# 1d set-node ; \ Port E - OLPC unused
+: portf ( -- ) h# 1e set-node ; \ Port F - OLPC DC input
+: portg ( -- ) h# 1f set-node ; \ Port G - speaker driver
+: porth ( -- ) h# 20 set-node ; \ Port H - S/PDIF out
+: porti ( -- ) h# 22 set-node ; \ Port I - S/PDIF out
+: portj ( -- ) h# 23 set-node ; \ Digital mic
+: vendor ( -- ) h# 25 set-node ; \ Vendor-specific controls
+
: volume-on-all ( -- )
- h# 14 to node h# 36006 cmd h# 35006 cmd
- h# 23 to node h# 36004 cmd h# 35004 cmd
- h# 17 to node h# 3a004 cmd h# 39004 cmd
- h# 18 to node h# 3a004 cmd h# 39004 cmd
- h# 14 to node h# 36200 cmd h# 35200 cmd
- h# 10 to node h# 3a03e cmd h# 3903e cmd
+ adc1 h# 36006 cmd h# 35006 cmd \ Left gain/mute, right gain/mute
+ portj h# 36004 cmd h# 35004 cmd \ Left gain, right gain
+ mux h# 3a004 cmd h# 39004 cmd \ Left gain, right gain
+ mux2 h# 3a004 cmd h# 39004 cmd \ Left gain, right gain
+ adc1 h# 36200 cmd h# 35200 cmd \ Left gain/mute, right gain/mute
+ dac1 h# 3a03e cmd h# 3903e cmd \ Left gain, right gain
;
-h# 1a value mic-in \ Port B
-h# 1b value mic \ Port C
-h# 17 value mux \ mux between the two
-
: pin-sense? ( -- ? ) h# f0900 cmd? h# 8000.0000 and 0<> ;
: set-connection ( n -- ) h# 70100 or cmd ;
: enable-hp-input ( -- ) h# 70721 cmd ;
: disable-hp-input ( -- ) h# 70700 cmd ;
: cx2058x-enable-recording ( -- )
- mic-in to node pin-sense? if
- mux to node 0 set-connection mic-in to node enable-hp-input
+ portb pin-sense? if
+ mux 0 set-connection portb enable-hp-input
else
- mux to node 1 set-connection mic to node enable-hp-input
+ mux 1 set-connection portc enable-hp-input
then
;
: cx2058x-disable-recording ( -- )
- mic-in to node disable-hp-input
- mic to node disable-hp-input
+ portb disable-hp-input
+ portc disable-hp-input
;
: cx2058x-enable-playback ( -- )
- h# 19 to node pin-sense? if \ headphones attached
- h# 1f to node power-off \ turn off speaker
- else \ no headphones
- h# 1f to node power-on \ turn on speaker
- then
- h# 10 to node h# 70640 cmd h# 20000 stream-format or cmd
+ porta pin-sense? if \ headphones attached
+ portg power-off \ turn off speaker
+ else \ no headphones
+ portg power-on \ turn on speaker
+ then
+ dac1 h# 70640 cmd \ 706sc - stream 4, channel 0
+ h# 20000 stream-format or cmd
;
: cx2058x-disable-playback ( -- ) ;
@@ -68,7 +84,7 @@
: unused ( u -- u ) h# 40000000 or ;
: builtin ( u -- u ) h# 80000000 or ;
-: config( ( node -- null-config-default ) to node 0 ;
+: config( ( node -- null-config-default ) 0 ;
: )config ( config-default -- )
\ set the high 24 bits of the config-default value
@@ -78,25 +94,24 @@
8 rshift h# ff and 71f00 or cmd
;
-: port-a ( -- u ) 19 config( 1/8" green left hp-out jack )config ;
-: port-b ( -- u ) 1a config( 1/8" pink left mic-in jack )config ;
-: port-c ( -- u ) 1b config( builtin front mic-in )config ;
-: port-d ( -- u ) 1c config( unused line-out )config ;
-: port-e ( -- u ) 1d config( unused line-out )config ;
-: port-f ( -- u ) 1e config( 1/8" pink left line-in jack )config ;
-: port-g ( -- u ) 1f config( builtin front speaker )config ;
-: port-h ( -- u ) 20 config( unused spdiff-out )config ;
-: port-i ( -- u ) 22 config( unused spdiff-out )config ;
-: port-j ( -- u ) 23 config( unused mic-in )config ;
: config-default ( -- u ) f1c00 cmd? ;
: setup-config-default ( -- )
- port-a port-b port-c port-d port-e port-f port-g port-h port-i port-j
+ porta config( 1/8" green left hp-out jack )config
+ portb config( 1/8" pink left mic-in jack )config
+ portc config( builtin front mic-in )config
+ portd config( unused line-out )config
+ porte config( unused line-out )config
+ portf config( 1/8" pink left line-in jack )config
+ portg config( builtin front speaker )config
+ porth config( unused spdiff-out )config
+ porti config( unused spdiff-out )config
+ portj config( unused mic-in )config
;
: vendor-settings ( -- )
- h# 25 to node
+ vendor
h# 290a8 cmd \ high-pass filter, semi-manual mode, 600Hz cutoff
h# 34001 cmd \ speaker power 1 dB gain
h# 38001 cmd \ over-current / short-circuit protection, 2.6A threshold
@@ -121,7 +136,7 @@
\ Test word to make sure the right settings are configured
: .vendor-settings ( -- )
- h# 25 to node
+ vendor
h# 0a8 h# a9000 check-cmd
h# 001 h# b4000 check-cmd
h# 001 h# b8000 check-cmd
@@ -135,17 +150,15 @@
;
: cx2058x-open ( -- )
- h# 10 to dac
- h# 14 to adc
+ ['] dac1 to with-dac
+ ['] adc1 to with-adc
power-on-all
volume-on-all
vendor-settings
setup-config-default
;
-: cx2058x-close ( -- )
- 1 to node ( function group) power-off
-;
+: cx2058x-close ( -- ) afg power-off ; \ Power off entire Audio Function Group
: cx2058x-init ( -- )
['] cx2058x-open to open-codec
Modified: dev/hdaudio/core.fth
===================================================================
--- dev/hdaudio/core.fth 2010-01-05 23:22:48 UTC (rev 1646)
+++ dev/hdaudio/core.fth 2010-01-07 08:04:00 UTC (rev 1647)
@@ -16,8 +16,8 @@
defer enable-codec-playback ' noop to enable-codec-playback
defer disable-codec-playback ' noop to disable-codec-playback
-0 value dac \ digital to analogue converter node id
-0 value adc \ analogue to digital converter node id
+defer with-dac \ select digital to analogue converter node
+defer with-adc \ select analogue to digital converter node
\ \ DMA setup
@@ -84,6 +84,11 @@
1 value sample-format
2 value #channels
+variable in-stream-format h# 10 in-stream-format ! \ 48kHz 16bit mono
+variable out-stream-format h# 11 out-stream-format ! \ 48kHz 16bit stereo
+
+defer selected-stream-format ' out-stream-format to selected-stream-format
+
: stream-format ( -- u )
sample-base d# 14 lshift ( acc )
sample-mul d# 11 lshift or ( acc )
@@ -92,19 +97,33 @@
#channels 1- or ( fmt )
;
-: sample-rate! ( base mul div ) to sample-div to sample-mul to sample-base ;
+: sample-rate! ( base mul div -- )
+ 8 lshift swap d# 11 lshift or swap d# 14 lshift or ( rate-code )
+ selected-stream-format @ h# ffffff00 invert and or selected-stream-format !
+;
+: sample-width! ( code -- )
+ 4 lshift
+ selected-stream-format @ h# f0 invert and or selected-stream-format !
+;
+: channels! ( #channels -- )
+ 1-
+ selected-stream-format @ h# f invert and or selected-stream-format !
+;
: 48kHz ( -- ) 0 0 0 sample-rate! ;
: 44.1kHz ( -- ) 1 0 0 sample-rate! ;
: 96kHz ( -- ) 0 1 0 sample-rate! ;
: 192kHz ( -- ) 0 3 0 sample-rate! ;
-: 8bit ( -- ) 0 to sample-format ;
-: 16bit ( -- ) 1 to sample-format ;
-: 20bit ( -- ) 2 to sample-format ;
-: 24bit ( -- ) 3 to sample-format ;
-: 32bit ( -- ) 4 to sample-format ;
+: 8bit ( -- ) 0 sample-width! ;
+: 16bit ( -- ) 1 sample-width! ;
+: 20bit ( -- ) 2 sample-width! ;
+: 24bit ( -- ) 3 sample-width! ;
+: 32bit ( -- ) 4 sample-width! ;
+: mono ( -- ) 1 channels! ;
+: stereo ( -- ) 2 channels! ;
+
\ Stream descriptor register interface.
\ There are multiple stream descriptors, each with their own register set.
0 value sd#
@@ -199,7 +218,7 @@
0 0 value codec value node \ current target for commands
-: encode-command ( codec node verb -- )
+: encode-command ( verb -- )
codec d# 28 lshift node d# 20 lshift or or
;
@@ -241,6 +260,7 @@
d# 48.000 value sample-rate
1 value scale-factor
+: upsampling? ( -- ? ) scale-factor 1 <> ;
: low-rate? ( Hz ) dup d# 48.000 < swap d# 44.100 <> and ;
@@ -278,34 +298,69 @@
\ \\ Sound buffer
\ Sample data for playback or recording.
-0 value sound-buffer
-0 value sound-buffer-phys
-0 value /sound-buffer
+0 value in-buffer
+0 value in-buffer-phys
+0 value /in-buffer
-: install-sound-buffer ( adr len -- )
- 2dup to /sound-buffer to sound-buffer
- true dma-map-in to sound-buffer-phys
+0 value out-buffer
+0 value out-buffer-phys
+0 value /out-buffer
+
+: install-in-buffer ( adr len -- )
+ 2dup to /in-buffer to in-buffer
+ true dma-map-in to in-buffer-phys
;
+: release-in-buffer ( -- )
+ in-buffer in-buffer-phys /in-buffer dma-map-out
+;
+
+: install-out-buffer ( adr len -- )
+ 2dup to /out-buffer to out-buffer
+ true dma-map-in to out-buffer-phys
+;
+
+: release-out-buffer ( -- )
+ out-buffer out-buffer-phys /out-buffer dma-map-out
+ \ If we are upsampling, we allocated out-buffer so we need to free it.
+ \ If not, the caller owns out-buffer.
+ upsampling? if out-buffer /out-buffer dma-free then
+;
+
\ Pad buffer: filled with zeros to pad out the end of the stream.
\ (Streams automatically repeat -- this is so we'll have time to stop
\ before that happens.)
-0 value pad-buffer
-0 value pad-buffer-phys
d# 8092 value /pad-buffer
-: alloc-pad-buffer ( -- )
- /pad-buffer dma-alloc to pad-buffer
- pad-buffer /pad-buffer true dma-map-in to pad-buffer-phys
- pad-buffer /pad-buffer 0 fill
+0 value in-pad
+0 value in-pad-phys
+
+: alloc-in-pad ( -- )
+ /pad-buffer dma-alloc to in-pad
+ in-pad /pad-buffer true dma-map-in to in-pad-phys
+ in-pad /pad-buffer 0 fill
;
-: free-pad-buffer ( -- )
- pad-buffer pad-buffer-phys /pad-buffer dma-map-out
- pad-buffer /pad-buffer dma-free
+: free-in-pad ( -- )
+ in-pad in-pad-phys /pad-buffer dma-map-out
+ in-pad /pad-buffer dma-free
;
+0 value out-pad
+0 value out-pad-phys
+
+: alloc-out-pad ( -- )
+ /pad-buffer dma-alloc to out-pad
+ out-pad /pad-buffer true dma-map-in to out-pad-phys
+ out-pad /pad-buffer 0 fill
+;
+
+: free-out-pad ( -- )
+ out-pad out-pad-phys /pad-buffer dma-map-out
+ out-pad /pad-buffer dma-free
+;
+
\ \\ Buffer Descriptor List
struct ( buffer descriptor )
@@ -315,54 +370,71 @@
4 field >bd-ioc
constant /bd
-0 value bdl
-0 value bdl-phys
+: set-buffer-descriptor ( phys uaddr len ioc bd-adr -- )
+ tuck >bd-ioc ! tuck >bd-len ! tuck >bd-uaddr ! >bd-laddr !
+;
+
d# 256 /bd * value /bdl
-: buffer-descriptor ( n -- adr ) /bd * bdl + ;
+0 value in-bdl
+0 value in-bdl-phys
-: allocate-bdl ( -- )
- /bdl dma-alloc to bdl
- bdl /bdl 0 fill
- bdl /bdl true dma-map-in to bdl-phys
+: in-buffer-descriptor ( n -- adr ) /bd * in-bdl + ;
+
+: allocate-in-bdl ( -- )
+ /bdl dma-alloc to in-bdl
+ in-bdl /bdl 0 fill
+ in-bdl /bdl true dma-map-in to in-bdl-phys
;
-: free-bdl ( -- ) bdl bdl-phys /bdl dma-map-out bdl /bdl dma-free ;
+: free-in-bdl ( -- ) in-bdl in-bdl-phys /bdl dma-map-out in-bdl /bdl dma-free ;
-: setup-bdl ( -- )
- allocate-bdl
- sound-buffer-phys 0 buffer-descriptor >bd-laddr ! ( len )
- 0 0 buffer-descriptor >bd-uaddr ! ( len )
- /sound-buffer 0 buffer-descriptor >bd-len ! ( )
- 1 0 buffer-descriptor >bd-ioc !
- \ pad buffer
- alloc-pad-buffer
- pad-buffer-phys 1 buffer-descriptor >bd-laddr !
- 0 1 buffer-descriptor >bd-uaddr !
- /pad-buffer 1 buffer-descriptor >bd-len !
- 0 1 buffer-descriptor >bd-ioc !
+: setup-in-bdl ( -- )
+ allocate-in-bdl
+ in-buffer-phys 0 /in-buffer 1 0 in-buffer-descriptor set-buffer-descriptor
+ alloc-in-pad
+ in-pad-phys 0 /pad-buffer 0 1 in-buffer-descriptor set-buffer-descriptor
;
-: teardown-bdl ( -- )
- free-bdl
- free-pad-buffer
+: teardown-in-bdl ( -- ) free-in-bdl free-in-pad ;
+
+0 value out-bdl
+0 value out-bdl-phys
+
+: out-buffer-descriptor ( n -- adr ) /bd * out-bdl + ;
+
+: allocate-out-bdl ( -- )
+ /bdl dma-alloc to out-bdl
+ out-bdl /bdl 0 fill
+ out-bdl /bdl true dma-map-in to out-bdl-phys
;
+: free-out-bdl ( -- ) out-bdl out-bdl-phys /bdl dma-map-out out-bdl /bdl dma-free ;
+
+: setup-out-bdl ( -- )
+ allocate-out-bdl
+ out-buffer-phys 0 /out-buffer 1 0 out-buffer-descriptor set-buffer-descriptor
+ alloc-out-pad
+ out-pad-phys 0 /pad-buffer 0 1 out-buffer-descriptor set-buffer-descriptor
+;
+
+: teardown-out-bdl ( -- ) free-out-bdl free-out-pad ;
+
\ \\ Stream descriptor (DMA engine)
-: setup-stream ( -- )
+: setup-out-stream ( -- )
reset-stream
- /sound-buffer /pad-buffer + sdcbl rl! \ bytes of stream data
+ /out-buffer /pad-buffer + sdcbl rl! \ bytes of stream data
h# 440000 sdctl rl! \ stream 4
1 sdlvi rw! \ two buffers
1c sdsts rb! \ clear status flags
- bdl-phys sdbdpl rl!
- 0 sdbdpu rl!
- stream-format sdfmt rw!
+ out-bdl-phys sdbdpl rl!
+ 0 sdbdpu rl!
+ out-stream-format @ sdfmt rw!
;
-: stream-done? ( -- ) sdsts c@ 4 and 0<> ;
-: wait-stream-done ( -- ) begin stream-done? until ;
+: stream-done? ( -- ) sdsts c@ 4 and 0<> ;
+: wait-stream-done ( -- ) begin stream-done? until ;
\ \\ Upsampling
@@ -425,52 +497,53 @@
\ \\ Playback
+4 constant out-sd
+
false value playing?
-: upsampling? ( -- ? ) scale-factor 1 <> ;
-
: open-out ( -- )
- 4 to sd#
+ ['] out-stream-format to selected-stream-format
d# 48.000 set-sample-rate
;
+: start-audio-out ( adr len -- )
+ install-out-buffer ( )
+ setup-out-bdl
+ out-sd to sd#
+ setup-out-stream
+ enable-codec-playback
+ start-stream
+ true to playing?
+;
: audio-out ( adr len -- actual )
dup >r
upsampling? if scale-factor upsample then ( adr len )
- install-sound-buffer ( )
- setup-bdl
- setup-stream
- enable-codec-playback
- start-stream
+ start-audio-out
r> ( actual )
;
-: release-sound-buffer ( -- )
- sound-buffer sound-buffer-phys /sound-buffer dma-map-out
- upsampling? if sound-buffer /sound-buffer dma-free then
-;
-
-: (write-done) ( -- )
+: stop-out ( -- )
+ out-sd to sd#
stop-stream
- teardown-bdl
- release-sound-buffer
+ teardown-out-bdl
+ release-out-buffer
uninstall-playback-alarm
+ false to playing?
;
-: write-done ( -- ) wait-stream-done (write-done) ;
+: write-done ( -- ) out-sd to sd# wait-stream-done stop-out ;
: write ( adr len -- actual )
- 4 to sd# audio-out true to playing? install-playback-alarm
+ audio-out install-playback-alarm
;
-: ?end-sound ( -- )
- 4 to sd#
- stream-done? if (write-done) false to playing? then
+: ?end-playing ( -- )
+ out-sd to sd# stream-done? if stop-out then
;
false value stop-lock
: stop-sound ( -- )
true to stop-lock
- playing? if (write-done) false to playing? then
+ playing? if stop-out then
false to stop-lock
;
@@ -478,7 +551,7 @@
: playback-completed-alarm ( -- )
stop-lock if exit then
playing? if
- sd# ?end-sound to sd#
+ ?end-playing
else
\ If playback has already stopped as a result of
\ someone else having waited for completion, we
@@ -492,13 +565,13 @@
: still-playing? ( -- flag )
playing? 0= if false exit then
stop-lock if true exit then
- sd# ?end-sound to sd#
+ ?end-playing
playing?
;
: wait-sound ( -- )
true to stop-lock
- begin playing? while d# 10 ms ?end-sound repeat
+ begin playing? while d# 10 ms ?end-playing repeat
false to stop-lock
;
@@ -506,7 +579,7 @@
false value right-mute?
: set-volume ( dB -- )
- dac to node
+ with-dac
dB>step#
dup left-mute? if h# 80 or then h# 3a000 or cmd \ left gain
right-mute? if h# 80 or then h# 39000 or cmd \ right gain
@@ -514,52 +587,84 @@
\ \\ Recording
+0 constant in-sd
0 value recbuf
0 value recbuf-phys
-d# 65535 value /recbuf
-: open-in ( -- ) d# 48.000 set-sample-rate ;
+: open-in ( -- )
+ ['] in-stream-format to selected-stream-format
+ d# 48.000 set-sample-rate
+;
-: record-stream ( -- )
- 0 to sd#
- 1 to #channels
+: setup-in-stream ( -- )
+ in-sd to sd#
+\ 1 to #channels
reset-stream
- /sound-buffer /pad-buffer + sdcbl rl! \ buffer length
+ /in-buffer /pad-buffer + sdcbl rl! \ buffer length
h# 100000 sdctl rl! \ stream 1, input
1 sdlvi rw! \ two buffers
h# 1c sdsts c! \ clear status flags
- bdl-phys sdbdpl rl!
- 0 sdbdpu rl!
- stream-format sdfmt rw!
- adc to node
- h# 70610 cmd \ stream 1, channel 0
- h# 20000 stream-format or cmd \ stream format
+ in-bdl-phys sdbdpl rl!
+ 0 sdbdpu rl!
+ in-stream-format @ sdfmt rw!
+ with-adc
+ h# 70610 cmd \ 706sc - stream 1, channel 0
+ h# 20000 in-stream-format @ or cmd \ stream format
;
-: audio-in ( adr len -- actual )
- install-sound-buffer ( )
- setup-bdl
- record-stream
+0 value recording?
+: start-audio-in ( adr len -- )
+ install-in-buffer ( )
+ setup-in-bdl
+ setup-in-stream
enable-codec-recording
start-stream
- wait-stream-done
+ true to recording?
+;
+: stop-in ( -- )
+ in-sd is sd#
stop-stream
- release-sound-buffer
- teardown-bdl
- /recbuf
+ teardown-in-bdl
+ release-in-buffer
+ false to recording?
;
+: ?end-recording ( -- )
+ in-sd to sd#
+ stream-done? if stop-in then
+;
+: audio-in ( adr len -- actual )
+ start-audio-in
+ wait-stream-done
+ stop-in
+ /in-buffer
+;
+: out-in ( out-adr out-len in-adr in-len -- )
+ upsampling? if 2swap scale-factor upsample 2swap then ( out-adr,len in-adr,len )
+ start-audio-in ( out-adr out-len )
+ start-audio-out ( )
+ begin
+ recording? if ?end-recording then
+ playing? if ?end-playing then
+ recording? 0= playing? 0= and
+ until
+;
+
: close-in ( -- ) disable-codec-recording ;
+: pbuf " load-base 10000" evaluate ;
+: rbuf " load-base 1meg + 20000" evaluate ;
+: bufs ( -- pbuf,len rbuf,len ) pbuf rbuf ;
+
0 value boost-db
: mic+20db ( -- ) d# 20 to boost-db ;
: mic+0db ( -- ) 0 to boost-db ;
-: set-record-gain ( dB -- ) ; \ adc to node step# input-gain ;
+: set-record-gain ( dB -- ) ; \ with-adc step# input-gain ;
: in-amp-caps ( -- u ) h# f000d cmd? ;
: in-gain-steps ( -- n ) in-amp-caps 8 rshift h# 7f and 1+ ;
-: set-record-gain ( dB -- ) drop ( hardcoded for now ) adc to node h# 40 input-gain ;
+: set-record-gain ( dB -- ) drop ( hardcoded for now ) with-adc h# 40 input-gain ;
\ LICENSE_BEGIN
Added: dev/hdaudio/noiseburst.fth
===================================================================
--- dev/hdaudio/noiseburst.fth (rev 0)
+++ dev/hdaudio/noiseburst.fth 2010-01-07 08:04:00 UTC (rev 1647)
@@ -0,0 +1,486 @@
+.( cross-covariance audio test) cr
+select /audio
+
+code mono-covar ( adr1 adr2 #samples -- d.sum )
+ cx pop
+
+ ax pop \ adr2 in ax
+ bx pop \ adr1 in bx
+ si push
+ di push
+ bp push
+
+ ax si mov
+ bx di mov
+
+ bp bp xor \ Zero accumulator
+ bx bx xor
+
+ begin
+ op: ax lods
+ cwde
+ ax dx mov
+ op: 0 [di] ax mov
+ 2 [di] di lea
+ cwde
+ dx imul
+ ax bx add
+ dx bp adc
+ loopa
+
+ bp ax mov
+
+ bp pop
+ di pop
+ si pop
+
+ bx push
+ ax push
+c;
+code stereo-mono-covar ( stereo-adr1 stereo-adr2 #samples -- d.sum )
+ cx pop
+
+ ax pop \ adr2 in ax
+ bx pop \ adr1 in bx
+ si push
+ di push
+ bp push
+
+ ax si mov
+ bx di mov
+
+ bp bp xor \ Zero accumulator
+ bx bx xor
+
+ begin
+ op: ax lods
+ cwde
+ ax dx mov
+ op: 0 [di] ax mov
+ 4 [di] di lea \ Skip 2 samples for stereo
+ cwde
+ dx imul
+ ax bx add
+ dx bp adc
+ loopa
+
+ bp ax mov
+
+ bp pop
+ di pop
+ si pop
+
+ bx push
+ ax push
+c;
+code stereo-covar ( stereo-adr1 stereo-adr2 #samples -- d.sum )
+ cx pop
+
+ ax pop \ adr2 in ax
+ bx pop \ adr1 in bx
+ si push
+ di push
+ bp push
+
+ ax si mov
+ bx di mov
+
+ bp bp xor \ Zero accumulator
+ bx bx xor
+
+ begin
+ op: ax lods
+ 2 [si] si lea \ Skip other channel sample for stereo
+ cwde
+ ax dx mov
+ op: 0 [di] ax mov
+ 4 [di] di lea \ Skip 2 samples for stereo
+ cwde
+ dx imul
+ ax bx add
+ dx bp adc
+ loopa
+
+ bp ax mov
+
+ bp pop
+ di pop
+ si pop
+
+ bx push
+ ax push
+c;
+code mono-wsum ( adr len -- d.sum )
+ cx pop
+
+ ax pop \ adr in ax
+ si push
+ bp push
+
+ ax si mov
+
+ bp bp xor \ Zero accumulator
+ bx bx xor
+
+ begin
+ op: ax lods
+ cwde
+ cwd \ Actually cdq
+ ax bx add
+ dx bp adc
+ loopa
+
+ bp ax mov
+
+ bp pop
+ si pop
+
+ bx push
+ ax push
+c;
+code stereo-wsum ( adr #samples -- d.sum )
+ cx pop
+
+ ax pop \ adr in ax
+ si push
+ bp push
+
+ ax si mov
+
+ bp bp xor \ Zero accumulator
+ bx bx xor
+
+ begin
+ op: ax lods
+ 2 [si] si lea \ Skip other channel sample for stereo
+ cwde
+ cwd \ Actually cdq
+ ax bx add
+ dx bp adc
+ loopa
+
+ bp ax mov
+
+ bp pop
+ si pop
+
+ bx push
+ ax push
+c;
+: mono-wmean ( adr len -- n )
+ 2/ tuck mono-wsum ( d.sum len )
+ rot m/mod nip ( mean )
+;
+: stereo-wmean ( adr len -- n )
+ 2/ 2/ tuck stereo-wsum ( d.sum len )
+ rot m/mod nip ( mean )
+;
+: -mono-wmean ( adr len -- )
+ 2dup mono-wmean ( adr len mean )
+ -rot bounds ?do ( mean )
+ i <w@ over - h# 7fff min h# -7fff max i w!
+ /w +loop ( mean )
+ drop ( )
+;
+: -stereo-wmean ( adr len -- )
+ 2dup stereo-wmean ( adr len mean )
+ -rot bounds ?do ( mean )
+ i <w@ over - h# 7fff min h# -7fff max i w!
+ /l +loop ( mean )
+ drop ( )
+;
+: lose-6db ( adr len -- )
+ bounds ?do ( )
+ i <w@ 2/ i w! ( )
+ /w +loop ( )
+;
+
+create testarr 100 0 do 0 w, 100 w, loop
+
+create testarr2 100 0 do 0 w, -100 w, loop
+
+: .covar# ( d.covar -- )
+ push-decimal
+ d# 1000000000 m/mod nip 8 .r
+ pop-base
+;
+: .m-covar ( adr1 adr2 len end-start -- )
+ do
+ i 3 u.r space ( adr1 adr2 len )
+ 3dup swap i wa+ swap mono-covar ( adr1 adr2 len d.covar )
+ .covar# cr ( adr1 adr2 len )
+ loop ( adr1 adr2 len )
+ 3drop ( )
+;
+: .sm-covar ( adr1 adr2 len end start -- )
+ do
+ i 3 u.r space ( adr1 adr2 len )
+ 3dup swap i wa+ swap stereo-mono-covar ( adr1 adr2 len d.covar )
+ .covar# cr ( adr1 adr2 len )
+ loop ( adr1 adr2 len )
+ 3drop ( )
+;
+
+0. 2value total-covar
+: sm-covar-sum ( adr1 adr2 len end start -- d.covar )
+ 0. to total-covar
+ do
+ 3dup swap i wa+ swap stereo-mono-covar ( adr1 adr2 len d.covar )
+ total-covar d+ to total-covar ( adr1 adr2 len )
+ loop ( adr1 adr2 len )
+ 3drop ( )
+ total-covar
+;
+: sm-covar-abs-sum ( adr1 adr2 len end start -- d.covar )
+ 0. to total-covar
+ do
+ 3dup swap i wa+ swap stereo-mono-covar ( adr1 adr2 len d.covar )
+ dabs total-covar d+ to total-covar ( adr1 adr2 len )
+ loop ( adr1 adr2 len )
+ 3drop ( )
+ total-covar
+;
+
+: ss-covar-abs-sum ( adr1 adr2 len end start -- d.covar )
+ 0. to total-covar
+ do
+ 3dup swap i la+ swap stereo-covar ( adr1 adr2 len d.covar )
+ dabs total-covar d+ to total-covar ( adr1 adr2 len )
+ loop ( adr1 adr2 len )
+ 3drop ( )
+ total-covar
+;
+
+
+0 value max-index
+0. 2value max-covar
+: mono-covar-max ( adr1 adr2 #samples max-dly min-dly -- index )
+ -1 to max-index ( adr1 adr2 #samples max-dly min-dly )
+ 0. to max-covar ( adr1 adr2 #samples max-dly min-dly )
+
+ do ( adr1 adr2 #samples )
+ 3dup swap i wa+ swap mono-covar ( adr1 adr2 #samples d.covar )
+ dabs ( adr1 adr2 #samples |d.covar| )
+ max-covar 2over d< if ( adr1 adr2 #samples |d.covar| )
+ to max-covar i to max-index ( adr1 adr2 #samples )
+ else ( adr1 adr2 #samples |d.covar| )
+ 2drop ( adr1 adr2 #samples )
+ then ( adr1 adr2 #samples )
+ loop ( adr1 adr2 #samples )
+ 3drop
+ max-index
+;
+: stereo-mono-covar-max ( adr1 adr2 #samples max-dly min-dly -- index )
+ -1 to max-index ( adr1 adr2 #samples max-dly min-dly )
+ 0. to max-covar ( adr1 adr2 #samples max-dly min-dly )
+
+ do ( adr1 adr2 #samples )
+ 3dup swap i wa+ swap stereo-mono-covar ( adr1 adr2 #samples d.covar )
+ dabs ( adr1 adr2 #samples |d.covar| )
+ max-covar 2over d< if ( adr1 adr2 #samples |d.covar| )
+ to max-covar i to max-index ( adr1 adr2 #samples )
+ else ( adr1 adr2 #samples |d.covar| )
+ 2drop ( adr1 adr2 #samples )
+ then ( adr1 adr2 #samples )
+ loop ( adr1 adr2 #samples )
+ 3drop
+ max-index
+;
+: mono-variance ( adr len -- d.variance )
+ >r dup r> 2/ mono-covar
+;
+: left-variance ( adr len -- d.variance )
+ >r dup r> 2/ 2/ stereo-covar
+;
+: right-variance ( adr len -- d.variance )
+ >r wa1+ dup r> 2/ 2/ stereo-covar
+;
+
+h# 40000 value /pb \ Stereo - 10000 is okay for fixter, 40000 is better for case,
+: pb load-base ;
+h# 21000 value /rb \ Mono (stereo for loopback) - 8100 for fixture, 21000 for case,
+: rb load-base 1meg + ;
+
+: random-signal ( -- )
+ pb /pb bounds do random-byte i c! loop
+ pb /pb -stereo-wmean
+ pb wa1+ /pb -stereo-wmean
+ pb /pb lose-6db
+;
+
+: d.. ( -- ) <# # # # # ascii . hold # # # # ascii . hold #s #> type space ;
+: find-max-mono ( -- )
+ pb rb /pb 2 / h# 100 - d# 160 d# 120 mono-covar-max .d max-covar d..
+;
+: find-max-left ( -- )
+ pb rb /pb 4 / h# 100 - d# 160 d# 120 stereo-mono-covar-max .d max-covar d..
+;
+: find-max-right ( -- )
+ pb wa1+ rb /pb 4 / h# 100 - d# 160 d# 120 stereo-mono-covar-max .d max-covar d..
+;
+
+: #samples ( -- n ) /pb 4 / h# 100 - ;
+: left-range ( -- stereo-adr mono-adr #points ) pb rb #samples ;
+: right-range ( -- stereo-adr mono-adr #points ) pb wa1+ rb #samples ;
+: left-stereo-range ( -- stereo-adr mono-adr #points ) pb rb #samples ;
+: right-stereo-range ( -- stereo-adr mono-adr #points ) pb wa1+ rb wa1+ #samples ;
+
+: fixture-analyze-left ( -- )
+ left-range d# 146 d# 141 sm-covar-sum dnegate
+ left-range d# 165 d# 155 sm-covar-sum d+
+ left-range d# 190 d# 180 sm-covar-sum dnegate d+
+ .covar#
+;
+: fixture-analyze-right ( -- )
+ right-range d# 146 d# 141 sm-covar-sum dnegate
+ right-range d# 165 d# 155 sm-covar-sum d+
+ right-range d# 190 d# 180 sm-covar-sum dnegate d+
+ .covar#
+;
+
+\ Reasonable threshold is d# 25
+: fixture-ratio-left ( -- )
+ left-range d# 240 d# 140 sm-covar-abs-sum nip ( sum1 )
+ left-range d# 400 d# 300 sm-covar-abs-sum nip ( sum1 sum2 )
+ d# 10 swap */
+ .d
+;
+: fixture-ratio-right ( -- )
+ right-range d# 240 d# 140 sm-covar-abs-sum nip ( sum1 )
+ right-range d# 400 d# 300 sm-covar-abs-sum nip ( sum1 sum2 )
+ d# 10 swap */
+ .d
+;
+
+\ This compares the total energy within the impulse response band to the
+\ total energy in a similar-length band
+: case-ratio-left ( -- ratio )
+ left-range d# 200 d# 140 sm-covar-abs-sum nip ( sum1.high )
+ left-range d# 540 d# 400 sm-covar-abs-sum nip ( sum1.high sum2.high )
+ d# 10 swap */
+ .d
+;
+: case-ratio-right ( -- ratio )
+ right-range d# 330 d# 140 sm-covar-abs-sum nip ( sum1.high )
+ right-range d# 590 d# 400 sm-covar-abs-sum nip ( sum1.high sum2.high )
+ d# 10 swap */
+ .d
+;
+
+\ This compares the total energy within the impulse response band to the
+\ total energy in a similar-length band
+: loopback-ratio-left ( -- )
+ left-stereo-range d# 148 d# 128 ss-covar-abs-sum nip ( sum1.high )
+ left-stereo-range d# 220 d# 200 ss-covar-abs-sum nip ( sum1.high sum2.high )
+ d# 10 swap */
+ .d
+;
+: loopback-ratio-right ( -- )
+ right-stereo-range d# 148 d# 128 ss-covar-abs-sum nip ( sum1.high )
+ right-stereo-range d# 220 d# 200 ss-covar-abs-sum nip ( sum1.high sum2.high )
+ d# 10 swap */
+ .d
+;
+
+
+d# 1024 /w* buffer: impulse-response
+
+: calc-sm-impulse ( offset -- ) \ offset is 0 for left or 2 for right
+ pb + rb #samples ( adr1 adr2 #samples )
+ d# 1024 0 do
+ 3dup swap i wa+ swap stereo-mono-covar ( adr1 adr2 #samples d.covar )
+ d# 50000000 m/mod nip ( adr1 adr2 #samples n.covar )
+ impulse-response i wa+ w! ( adr1 adr2 #samples )
+ loop ( adr1 adr2 len )
+ 3drop ( )
+;
+: .samples ( adr end start -- )
+ do
+ i push-decimal 3 u.r pop-base ( adr )
+ dup i wa+ <w@ push-decimal 8 .r pop-base cr ( adr )
+ loop ( adr )
+ drop
+;
+d# -23 value test-volume \ d# -23 for test fixture, d# -9 for in-case
+defer rx-channels ' mono is rx-channels \ set to stereo for loopback
+defer analyze-left
+defer analyze-right
+defer fix-dc
+: setup-fixture ( -- )
+ xxx - this needs to use the internal speakers and mic even though the loopback cable is attached
+ ['] mono is rx-channels
+ d# -23 is test-volume
+ h# 20000 to /pb \ Medium burst
+ /pb 2/ h# 1000 + to /rb \ Mono reception (internal mic)
+\ ['] fixture-analyze-left to analyze-left
+\ ['] fixture-analyze-right to analyze-right
+ ['] fixture-ratio-left to analyze-left
+ ['] fixture-ratio-right to analyze-right
+ ['] -mono-wmean to fix-dc
+;
+: setup-case ( -- )
+ xxx - this needs to use the internal speakers and mic even though the loopback cable is attached
+ ['] mono is rx-channels
+ d# -9 is test-volume
+ h# 40000 to /pb \ Long burst for better S/N on far away speaker
+ /pb 2/ h# 1000 + to /rb \ Mono reception (internal mic)
+ ['] case-ratio-left to analyze-left
+ ['] case-ratio-right to analyze-right
+ ['] -mono-wmean to fix-dc
+;
+: setup-loopback ( -- )
+ ['] stereo is rx-channels
+ d# -33 is test-volume
+ h# 10000 to /pb \ Short burst
+ /pb h# 1000 + to /rb \ Stereo reception
+ ['] loopback-ratio-left to analyze-left
+ ['] loopback-ratio-right to analyze-right
+ ['] -stereo-wmean to fix-dc
+;
+: doit ( -- )
+ open-in 48kHz 16bit rx-channels with-adc d# 73 input-gain
+ \ -23 prevents obvious visible clipping
+ open-out 48kHz 16bit stereo test-volume set-volume
+ random-signal
+ lock[ \ Prevent timing jitter due to interrupts
+ pb /pb rb /rb out-in
+ ]unlock
+ rb /rb fix-dc
+\ ." Mono " find-max-mono cr
+\ ." Left " find-max-left cr
+\ ." Right " find-max-right cr
+ analyze-left analyze-right
+;
+
+0 [if]
+: make-tone2 ( freq -- )
+ sample-rate to fs ( freq ) set-freq
+
+ \ Start with everything quiet
+ record-base record-len erase
+
+ record-base make-cycle drop
+
+ \ Duplicate left into right
+ record-base #cycle /l* bounds ?do i w@ i wa1+ w! /l +loop
+
+ \ Replicate the wave template
+ record-base /cycle + record-len /cycle - bounds ?do
+ record-base i /cycle move
+ /cycle +loop
+;
+: freqtest ( frequency -- )
+ open-in 48kHz 16bit mono with-adc d# 73 input-gain
+ \ -23 prevents obvious visible clipping
+ open-out 48kHz 16bit stereo d# -23 set-volume
+
+ pb to record-base /pb to record-len
+ make-tone2
+
+ lock[ \ Prevent timing jitter due to interrupts
+ pb /pb rb /rb out-in
+ ]unlock
+ rb waveform
+;
+[then]
+.( loaded) cr
