r1647 - in dev: geode/ac97 hdaudio

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