Changeset 2260


Ignore:
Timestamp:
Jun 10, 2011, 11:51:31 PM (4 years ago)
Author:
wmb
Message:

OLPC XO-1.75 trac #10886 - autocorrelation-based audio selftest for XO-1.75

Files:
7 edited

Legend:

Unmodified
Added
Removed
  • cpu/arm/olpc/1.75/alc5631.fth

    r2246 r2260  
    1515   d# 100 ms
    1616
    17    h# 8021 h# 34 codec!  \ Slave mode, 16 bits, left justified, left channel on LRCLK high
     17   h# 8001 h# 34 codec!  \ Slave mode, 16 bits, left justified
    1818
    1919   h# 1010 h# 38 codec!  \ Divisors; the values in this register don't seem to make much
     
    9696false value force-speakers?
    9797: set-volume  ( n -- )
    98    headphones-inserted?  force-speakers? 0=  and  if
    99       set-headphone-volume
     98   headphones-inserted?  ( force-speakers? 0= and )  if
     99      set-headphone-volume mute-speakers
    100100   else
    101       set-speaker-volume
     101      set-speaker-volume mute-headphones
    102102   then
    103103;
     
    180180: set-default-gains  ( -- )
    181181   output-config
    182    headphones-inserted?  force-speakers? 0= and if
     182   headphones-inserted?  ( force-speakers? 0= and  ) if
    183183      headphones-on
    184184      speakers-off
  • cpu/arm/olpc/1.75/sound.fth

    r2246 r2260  
    4949: reset-rx  ( -- )  h# 8000.0002 h# 0c sspa!  ;
    5050
     51: active-low-rx-fs  ( -- )
     52   h# 0c sspa@  h# 8001.0000 or  h# 0c sspa!
     53;
     54: active-high-rx-fs  ( -- )
     55   h# 0c sspa@  h# 10000 invert and  h# 8000.0000 or  h# 0c sspa!
     56;
    5157: setup-sspa-rx  ( -- )
    5258   reset-rx
     
    6571   h# 8000.0000          \ Enable writes
    6672   d# 15 d# 20 lshift or \ Frame sync width
    67 \ We choose the master/slave configuration later, in enable-sspa-tx
     73\ We choose the master/slave configuration later, in enable-sspa-rx
    6874   0     d# 18 lshift or \ Internal clock - master configuration
    6975   0     d# 17 lshift or \ Sample on rising edge of clock
    70    0     d# 16 lshift or \ Active high frame sync
     76   1     d# 16 lshift or \ Active low frame sync (I2S standard)
    7177   d# 31 d#  4 lshift or \ Frame sync period
    7278   1     d#  2 lshift or \ Flush the FIFO
     
    8187: reset-tx  ( -- )  h# 8000.0002 h# 8c sspa!  ;
    8288
     89: active-low-tx-fs  ( -- )
     90   h# 8c sspa@  h# 8001.0000 or  h# 8c sspa!
     91;
     92: active-high-tx-fs  ( -- )
     93   h# 8c sspa@  h# 10000 and  h# 8000.0000 or  h# 8c sspa!
     94;
    8395: setup-sspa-tx  ( -- )
    8496   reset-tx
     
    101113   0     d# 18 lshift or \ External clock - slave configuration (Rx is master)
    102114   0     d# 17 lshift or \ Sample on rising edge of clock
    103    0     d# 16 lshift or \ Active high frame sync
     115
     116\ Empirically, this needs to be backwards from what we think it should be
     117   0     d# 16 lshift or \ Active high frame sync (should be active low, but that gives backwards results)
     118
    104119   d# 31 d#  4 lshift or \ Frame sync period
    105120   1     d#  2 lshift or \ Flush the FIFO
     
    248263: open-in   ( -- )  ;
    249264: close-in  ( -- )  ;
    250 : open-out  ( -- )  setup-sspa-tx  ;
     265: open-out  ( -- )  ;
    251266: close-out ( -- )  ;
    252267
     
    275290: stop-out  ( -- )
    276291   disable-sspa-tx
     292   reset-tx
    277293   stop-out-ring
    278294   uninstall-playback-alarm
     
    314330   to out-len            ( adr )
    315331   to out-adr            ( )
     332   setup-sspa-tx         ( )
    316333   make-out-ring
    317334   copy-out
     
    370387   repeat                      ( actual )
    371388   disable-sspa-rx             ( actual )
     389   reset-rx                    ( actual )
    372390;
    373391: read  ( adr len -- actual )  open-in audio-in  ;
    374392
     3930 value mono?
     3940 value in-adr0
     3950 value in-len0
     396: collapse-in  ( -- )
     397   in-len0  0  ?do
     398      in-adr0 i la+ w@   in-adr0 i wa+ w!
     399   loop
     400;
    375401: out-in  ( out-adr out-len in-adr in-len -- )
    376    to in-len   to in-adr       ( out-adr out-len )
     402   to in-len0  to in-adr0      ( out-adr out-len )
    377403   to out-len  to out-adr      ( )
     404
     405   in-adr0 to in-adr           ( )
     406   in-len0  mono?  if  2*  then  to in-len     
     407
     408   audio-clock-on              ( ) \ This will mess up any frequency settings
    378409
    379410   setup-sspa-tx               ( )
    380411   setup-sspa-rx               ( )
     412   active-high-rx-fs           ( )
    381413
    382414   make-in-ring                ( )
     
    403435   disable-sspa-tx             ( )
    404436
     437   reset-rx
     438   reset-tx
     439
    405440   dac-off  adc-off            ( )
     441
     442   mono?  if  collapse-in  then  ( )
    406443;
    407444
     
    453490;
    454491
    455 : stereo  ;
    456 : mono  ;
     492: stereo  false to mono?  ;
     493: mono  true to mono?  ;
    457494
    458495: init-codec  ( -- )
     
    4875242 value #channels
    488525fload ${BP}/dev/hdaudio/test.fth
     526: input-settings  ( -- )
     527   audio-clock-on              ( )  \ If you don't do this, the L/R phase is often wrong
     528;
     529: output-settings  ( -- )  ;
     530' input-settings to input-common-settings
     531' output-settings to output-common-settings
    489532
    490533end-package
  • dev/hdaudio/noiseburst.fth

    r2254 r2260  
    303303;
    304304: -stereo-wmean  ( adr len -- )
    305    2dup stereo-wmean  ( adr len mean )
    306    -rot  bounds  ?do  ( mean )
    307       i <w@ over - h# 7fff min  h# -7fff max  i w!
     305   2dup stereo-wmean >r  ( adr len r: lmean )
     306   over wa1+ over  stereo-wmean r> swap ( adr len lmean rmean )
     307   2swap  bounds  ?do                   ( lmean rmean )
     308      i      <w@ 2 pick - h# 7fff min  h# -7fff max  i      w!
     309      i wa1+ <w@ over   - h# 7fff min  h# -7fff max  i wa1+ w!
    308310   /l +loop           ( mean )
    309311   drop               ( )
     
    341343;
    342344
     345\ sample-delay accounts for the different timing between adc-on and dac-on
     346\ for different combinations of codec and controller.
     347
     348d# 0 value sample-delay
     349: +sample-delay  ( start #samples -- end' start' )
     350   swap  sample-delay +  swap bounds
     351;
    3433520. 2value total-covar
    344 : sm-covar-sum  ( adr1 adr2 len end start -- d.covar )
     353: sm-covar-sum  ( adr1 adr2 len start #samples -- d.covar )
     354   +sample-delay      ( adr1 adr2 len end' start' )
    345355   0. to total-covar
    346356   do
     
    349359   loop                 ( adr1 adr2 len )
    350360   3drop                ( )
    351    total-covar
    352 ;
    353 : sm-covar-abs-sum  ( adr1 adr2 len end start -- d.covar )
     361   total-covar  d2* d2*
     362;
     363: sm-covar-abs-sum  ( adr1 adr2 len start #samples -- d.covar )
     364   +sample-delay      ( adr1 adr2 len end' start' )
    354365   0. to total-covar
    355366   do
     
    358369   loop                 ( adr1 adr2 len )
    359370   3drop                ( )
    360    total-covar
    361 ;
    362 
    363 : ss-covar-abs-sum  ( adr1 adr2 len end start -- d.covar )
     371   total-covar  d2* d2*
     372;
     373
     374: ss-covar-abs-sum  ( adr1 adr2 len start #samples -- d.covar )
     375   +sample-delay      ( adr1 adr2 len end' start' )
    364376   0. to total-covar
    365377   do
     
    368380   loop                 ( adr1 adr2 len )
    369381   3drop                ( )
    370    total-covar
     382   total-covar  d2* d2*
    371383;
    372384
     
    458470;
    459471
     472d# 100 value #fixture
     473d# 25 value fixture-threshold
    460474: fixture-ratio-left  ( -- error? )
    461    left-range  d# 160 d#  60 sm-covar-abs-sum nip  ( sum1 )
    462    left-range  d# 400 d# 300 sm-covar-abs-sum nip  ( sum1 sum2 )
     475   left-range  d#  60 #fixture sm-covar-abs-sum nip  ( sum1 )
     476   left-range  d# 300 #fixture sm-covar-abs-sum nip  ( sum1 sum2 )
    463477   >ratio
    464    d# 25 <
     478   fixture-threshold <
    465479;
    466480: fixture-ratio-right  ( -- error? )
    467    right-range  d# 160 d#  60 sm-covar-abs-sum nip  ( sum1 )
    468    right-range  d# 400 d# 300 sm-covar-abs-sum nip  ( sum1 sum2 )
     481   right-range  d#  60 #fixture sm-covar-abs-sum nip  ( sum1 )
     482   right-range  d# 300 #fixture sm-covar-abs-sum nip  ( sum1 sum2 )
    469483   >ratio
    470    d# 25 <
    471 ;
     484   fixture-threshold <
     485;
     486
     487d#  60 value case-start-left
     488d#  60 value case-start-right
     489d# 400 value case-start-quiet
     490d#  60 value #case-left
     491d# 190 value #case-right
     492d#  25 value case-threshold-left
     493d#  14 value case-threshold-right
    472494
    473495\ This compares the total energy within the impulse response band to the
    474496\ total energy in a similar-length band
    475497: case-ratio-left  ( -- error? )
    476    left-range  d# 120 d#  60 sm-covar-abs-sum  nip ( sum1.high )
    477    left-range  d# 460 d# 400 sm-covar-abs-sum  nip ( sum1.high sum2.high )
     498   left-range  case-start-left  #case-left sm-covar-abs-sum  nip ( sum1.high )
     499   left-range  case-start-quiet #case-left sm-covar-abs-sum  nip ( sum1.high sum2.high )
    478500   >ratio
    479    d# 25 <
     501   case-threshold-left <
    480502;
    481503: case-ratio-right  ( -- error? )
    482     right-range  d# 250 d#  60 sm-covar-abs-sum  nip ( sum1.high )
    483     right-range  d# 590 d# 400 sm-covar-abs-sum  nip ( sum1.high sum2.high )
     504   right-range  case-start-right #case-right sm-covar-abs-sum  nip ( sum1.high )
     505   right-range  case-start-quiet #case-right sm-covar-abs-sum  nip ( sum1.high sum2.high )
    484506   >ratio
    485    d# 14 <
    486 ;
    487 
     507   case-threshold-right <
     508;
     509
     510d# 20 value #loopback
     511d# 70 value loopback-threshold
    488512\ This compares the total energy within the impulse response band to the
    489513\ total energy in a similar-length band
    490514: loopback-ratio-left  ( -- error? )
    491    left-stereo-range  d#  68 d#  48 ss-covar-abs-sum  nip ( sum1.high )
    492    left-stereo-range  d# 220 d# 200 ss-covar-abs-sum  nip ( sum1.high sum2.high )
     515   left-stereo-range  d#  48 #loopback ss-covar-abs-sum  nip ( sum1.high )
     516   left-stereo-range  d# 200 #loopback ss-covar-abs-sum  nip ( sum1.high sum2.high )
    493517   >ratio
    494    d# 70 <
     518   loopback-threshold <
    495519;
    496520: loopback-ratio-right  ( -- error? )
    497    right-stereo-range  d#  68 d#  48 ss-covar-abs-sum  nip ( sum1.high )
    498    right-stereo-range  d# 220 d# 200 ss-covar-abs-sum  nip ( sum1.high sum2.high )
     521   right-stereo-range  d#  48 #loopback ss-covar-abs-sum  nip ( sum1.high )
     522   right-stereo-range  d# 200 #loopback ss-covar-abs-sum  nip ( sum1.high sum2.high )
    499523   >ratio
    500    d# 70 <
     524   loopback-threshold <
     525;
     526
     527\ Ideally we would not put platform-specific information in this module.
     528\ If we add many more platforms, this should be redesigned.
     529: configure-xo1.75  ( -- )
     530   d# -23 to sample-delay
     531   d# 50 to fixture-threshold
     532   d# 40 to #fixture
     533   d# 83 to case-start-right
     534   d# 30 to #case-right
     535   d# 25 to case-threshold-right
    501536;
    502537
     
    508543   #impulse-response 0  do
    509544      3dup swap i wa+ swap stereo-mono-covar  ( adr1 adr2 #samples d.covar )
    510       d# 50000000 m/mod nip                   ( adr1 adr2 #samples n.covar )
     545      d# 500,000,000 m/mod nip                ( adr1 adr2 #samples n.covar )
    511546      impulse-response i wa+ w!               ( adr1 adr2 #samples )
    512547   loop                 ( adr1 adr2 len )
     
    517552   dup pb +  swap rb +  #samples              ( adr1 adr2 #samples )
    518553   #impulse-response 0  do
    519       3dup swap i wa+ swap stereo-covar       ( adr1 adr2 #samples d.covar )
    520       d# 50000000 m/mod nip                   ( adr1 adr2 #samples n.covar )
     554      3dup swap i la+ swap stereo-covar       ( adr1 adr2 #samples d.covar )
     555      d#  50,000,000 m/mod nip                ( adr1 adr2 #samples n.covar )
    521556      impulse-response i wa+ w!               ( adr1 adr2 #samples )
    522557   loop                 ( adr1 adr2 len )
     
    562597   h# 20000 to /pb          \ Medium burst
    563598   /pb 2/ h# 1000 + to /rb  \ Mono reception (internal mic)
    564 \   ['] fixture-analyze-left  to analyze-left
    565 \   ['] fixture-analyze-right to analyze-right
    566599   ['] fixture-ratio-left  to analyze-left
    567600   ['] fixture-ratio-right to analyze-right
  • dev/hdaudio/test.fth

    r2246 r2260  
    109109defer output-common-settings
    110110[ifdef] with-adc
    111 \ XXX this is hd-audio specific.  Factore it out
     111\ XXX this is hd-audio specific.  Factor it out
    112112: (input-common-settings)  ( -- )
    113113   open-in  48kHz  16bit  with-adc d# 73 input-gain
     
    121121
    122122: test-with-case  ( -- )
    123    " setup-case" $call-analyzer
     123\   " setup-case" $call-analyzer
    124124\   xxx - this needs to use the internal speakers and mic even though the loopback cable is attached
    125125   true to force-speakers?  true to force-internal-mic?
     126   mic-bias-on
    126127   input-common-settings  mono
    127    output-common-settings  d# -9 set-volume
     128   output-common-settings  d# -1 set-volume
    128129   ." Testing internal speakers and microphone" cr
    129130   " setup-case" test-common
     
    136137: test-with-fixture  ( -- error? )
    137138   true to force-speakers?  true to force-internal-mic?
     139   mic-bias-on
    138140   input-common-settings  mono
    139    output-common-settings  d# -23 set-volume  \ -23 prevents obvious visible clipping
     141   output-common-settings  d# -13 set-volume  \ -23 prevents obvious visible clipping
    140142   ." Testing internal speakers and microphone with fixture" cr
    141143   " setup-fixture" test-common
     
    147149;
    148150: test-with-loopback  ( -- error? )
    149    input-common-settings  stereo
    150    output-common-settings  d# -33 set-volume  \ -23 prevents obvious visible clipping
     151   mic-bias-off
     152   input-common-settings   stereo
     153   output-common-settings  d# -22 set-volume
    151154   ." Testing headphone and microphone jacks with loopback cable" cr
    152155   " setup-loopback" test-common
     
    194197   then
    195198;
     199: configure-platform  ( -- )
     200   board-revision  h# 1a28 >=  if  " configure-xo1.75" $call-analyzer  exit  then
     201;
    196202\ Returns failure by throwing
    197203: automatic-test  ( -- )
     204   configure-platform   
     205   disconnect-loopback  \ Not for 1.5; it can test internal while loopback is connected
    198206   " smt-test?" evaluate  if
    199207      test-with-fixture throw
  • forth/kernel/double.fth

    r1430 r2260  
    4444: -drot ( d1 d2 d3 -- d3 d1 d2 )  drot drot  ;
    4545: dinvert  ( d1 -- d2 )  swap invert  swap invert  ;
     46
     47: dlshift  ( d1 n -- d2 )
     48   tuck lshift >r                           ( low n  r: high2 )
     49   2dup bits/cell  swap - rshift  r> or >r  ( low n  r: high2' )
     50   lshift r>                                ( d2 )
     51;
     52: drshift  ( d1 n -- d2 )
     53   2dup rshift >r                           ( low high n  r: high2 )
     54   tuck  bits/cell swap - lshift            ( low n low2  r: high2 )
     55   -rot  rshift  or                         ( low2  r: high2 )
     56   r>                                       ( d2 )
     57;
     58: d>>a  ( d1 n -- d2 )
     59   2dup rshift >r                           ( low high n  r: high2 )
     60   tuck  bits/cell swap - lshift            ( low n low2  r: high2 )
     61   -rot  >>a  or                            ( low2  r: high2 )
     62   r>                                       ( d2 )
     63;
     64
    4665\ LICENSE_BEGIN
    4766\ Copyright (c) 2006 FirmWorks
  • forth/lib/isin.fth

    r2019 r2260  
    17170 value fstep
    18180 value #cycle
    19 0 value #half-cycle
    20 0 value #quarter-cycle
     190 value #cycle/2
     200 value #cycle/4
    2121
    2222: set-freq  ( freq sample-rate -- )
     
    2525   pi * to fstep
    2626   fs freq /  dup  to #cycle
    27    2/         dup  to #half-cycle
    28    2/              to #quarter-cycle
     27   2/         dup  to #cycle/2
     28   2/              to #cycle/4
    2929;
    30 : set-period  ( quarter-cycle -- )
    31    dup to #quarter-cycle       ( quarter-cycle )
    32    2* dup to #half-cycle       ( half-cycle )
     30: set-period  ( cycle/4 -- )
     31   dup to #cycle/4       ( cycle/4 )
     32   2* dup to #cycle/2       ( cycle/2 )
    3333   2* dup to #cycle            ( cycle )
    3434   fs over / to freq           ( period )
    35    pi swap /  fs *  to fstep   ( )
     35   pi fs rot */  to fstep      ( )
    3636;
    3737
     
    4343: sin-step  ( last divisor -- next )  thetasq  swap /  times  one min  one swap -  ;
    4444
     450 [if]
     46\ Cos
     47\ 1 - t^2/(2) + t^4/(2..4) - t^6/2..6) + t^8/(2..8)
     48\ 1 - (t^2/(1*2)) * (1 - (t^2/(3*4)) * (1 - (t^2/(5*6)) * (1 - (t^2/(7*8))))
     49
     50: icos  ( index -- frac )
     51   fstep fs 2/  */  to theta
     52   theta dup times  to thetasq
     53   one  d# 90 cos-step  d# 56 cos-step d# 30 cos-step  d# 12 cos-step  2 cos-step  one min
     54;
     55[then]
     56
    4557\ Taylor series expansion of sin, calculated as
     58\ t - t^3/(2*3) + t^5/(2*3*4*5) - t^7/(2..7) + t^9/(2...9)
    4659\ theta * (1 - (theta^2/(2*3)) * (1 - (theta^2/(4*5)) * (1 - (theta^2/(6*7)) * (1 - (theta^2/(8*9))))))
    4760\ This is good for the first quadrant only, i.e. 0 <= index <= fs / freq / 4
    48 : isin  ( index -- frac )
    49    fstep *  fs 2/  /  to theta
     61: calc-sin  ( index -- frac )
     62   fstep fs 2/  */  to theta
    5063   theta dup times to thetasq
    5164   one  d# 72 sin-step d# 42 sin-step  d# 20 sin-step  6 sin-step  theta times  one min
     
    5366
    5467: one-cycle  ( adr -- )
    55    #quarter-cycle 1+  0  do   ( adr )
    56       i isin
     68   #cycle/4 1+  0  do   ( adr )
     69      i calc-sin
    5770      2dup  swap  i wa+ w!                ( adr isin )
    58       2dup  swap  #half-cycle i - wa+ w!  ( adr isin )
     71      2dup  swap  #cycle/2 i - wa+ w!     ( adr isin )
    5972      negate                              ( adr -isin )
    60       2dup  swap  #half-cycle i + wa+ w!  ( adr -isin )
     73      2dup  swap  #cycle/2 i + wa+ w!     ( adr -isin )
    6174      over  #cycle i - wa+ w!             ( adr )
    6275   loop                                   ( adr )
    6376   drop
    6477;
     78
     79
     800 [if]
     81: reduce-to-quarter-cycle  ( -- )
     82   \ Move a cycle/4 to the left until negative, then fix
     83   #cycle/4 -  dup 0<=  if  #cycle/4 +  (sin)          exit  then  ( theta' )  \ Quadrant 1
     84   #cycle/4 -  dup 0<=  if  negate      (sin)          exit  then  ( theta' )  \ Quadrant 2
     85   #cycle/4 -  dup 0<=  if  #cycle/4 +  (sin)  negate  exit  then  ( theta' )  \ Quadrant 3
     86   #cycle/4 -               negate      (sin)  negate                          \ Quadrant 4
     87;
     88[then]
     89
     90\ For isin and icos we use a cosine table instead of a sine table.
     91\ Argument reduction is a bit easier for cos because it is an even function.
     92: one-cycle-cos  ( adr -- )
     93   #cycle/4 1+  0  do   ( adr )
     94      i calc-sin                           ( adr isin )
     95      2dup  swap  #cycle/4     i - wa+ w!  ( adr isin )  \ Quadrant 1
     96      2dup  swap  #cycle/4 3 * i + wa+ w!  ( adr isin )  \ Quadrant 4
     97      negate                               ( adr -isin )
     98      2dup  swap  #cycle/4     i + wa+ w!  ( adr -isin ) \ Quadrant 2
     99      over        #cycle/4 3 * i - wa+ w!  ( adr )       \ Quadrant 3
     100   loop                                    ( adr )
     101   drop
     102;
     103
     104\ The scale factor for theta is such that h# 10000 is pi radians.
     105\ Binary 1 is therefore pi/2^16
     1060 value cos-table
     107: init-sincos  ( -- )
     108   cos-table  if  exit  then
     109   h# 20000 /w* alloc-mem  to cos-table
     110   1 h# 20000 set-freq
     111   cos-table one-cycle-cos
     112;
     113: release-cos-table  ( -- )  cos-table h# 20000 /w* free-mem  0 to cos-table  ;
     114
     115: icos  ( theta -- cos )
     116   abs                                    ( theta' )
     117   dup #cycle  >=  if  #cycle mod  then   ( theta' )
     118   cos-table swap wa+ <w@                 ( cos )
     119;   
     120: isin  ( theta -- sin )  #cycle/4 -  icos  ;
     121
    65122
    66123\ d# 16000 to fs
  • forth/lib/tones.fth

    r2019 r2260  
    44
    55: make-cycle  ( adr -- adr' )
    6    #quarter-cycle 1+  0  do               ( adr )
    7       i isin                              ( adr isin )
    8       2dup  swap  i la+ w!                ( adr isin )
    9       2dup  swap  #half-cycle i - la+ w!  ( adr isin )
    10       negate                              ( adr -isin )
    11       2dup  swap  #half-cycle i + la+ w!  ( adr -isin )
    12       over  #cycle i - la+ w!             ( adr )
    13    loop                                   ( adr )
     6   #cycle/4 1+  0  do                  ( adr )
     7      i calc-sin                       ( adr isin )
     8      2dup  swap  i la+ w!             ( adr isin )
     9      2dup  swap  #cycle/2 i - la+ w!  ( adr isin )
     10      negate                           ( adr -isin )
     11      2dup  swap  #cycle/2 i + la+ w!  ( adr -isin )
     12      over  #cycle i - la+ w!          ( adr )
     13   loop                                ( adr )
    1414   /cycle +
    1515;
Note: See TracChangeset for help on using the changeset viewer.