File:  [gforth] / gforth / contrib / divspeed.fs
Revision 1.3: download - view: text, annotated - select for diffs
Sun Dec 31 10:24:51 2006 UTC (12 years, 7 months ago) by anton
Branches: MAIN
CVS tags: HEAD
minor change

    1: \ divspeed.fs
    2: \
    3: \ Measure speed of division words in gforth.
    4: \
    5: \ Krishna Myneni, 2006-10-26;
    6: \ Revisions:
    7: \    2006-10-28  change DIVIDEND for 32-bit systems;
    8: \                add tests for */ and M*/  ae, km
    9: (
   10:  In the development version of gforth, code has been added to test for division
   11:  by zero in the division words. We want to measure the performance penalty
   12:  introduced by these tests. Words to be checked are:
   13: 
   14:    /
   15:    MOD
   16:    /MOD
   17:    */
   18:    */MOD
   19:    FM/MOD
   20:    SM/REM
   21:    UM/MOD
   22:    M*/
   23: )
   24: 
   25: : ms@ ( -- u | return time in ms)  cputime d+ 1 1000 m*/ d>s ;
   26: : ?allot ( u -- a ) here swap allot ;
   27: : table ( v1 v2 ... vn n <name> -- | create a table of singles ) 
   28:         create dup cells ?allot over 1- cells + swap
   29:         0 ?do dup >r ! r> 1 cells - loop drop ;
   30: 
   31: 1 31 lshift 1- constant  DIVIDEND
   32: DIVIDEND negate s>d 2constant D_DIVIDEND
   33: 1000000     constant  N
   34: 
   35: \ Some helpful macros
   36: variable xt
   37: s" :noname [ xt @ >name name>string ] 2literal type ms@" 2constant s1
   38:     
   39: : get-xt ( "op" -- ) bl word find 0= ABORT" Unknown word!" xt ! ;
   40: 
   41: : testA ( "op" -- )
   42:     get-xt s1 evaluate
   43:     s" DIVIDEND  N 1 DO dup I" evaluate xt @ compile,
   44:     s" drop LOOP drop ;" evaluate ; immediate
   45: 
   46: : testB ( "op" -- )
   47:     get-xt s1 evaluate
   48:     s" DIVIDEND  N 1 DO dup I" evaluate xt @ compile,
   49:     s" 2drop LOOP drop ;" evaluate ; immediate
   50:  
   51: : testC ( "op" -- )
   52:     get-xt s1 evaluate
   53:     s" D_DIVIDEND N 1 DO  2dup I" evaluate xt @ compile,
   54:     s" 2drop LOOP 2drop ;" evaluate ; immediate
   55: 
   56: : testD ( "op" -- )
   57:     get-xt s1 evaluate
   58:     s" DIVIDEND s>d N 1 DO  2dup I" evaluate xt @ compile,
   59:     s" 2drop LOOP 2drop ;" evaluate ; immediate
   60: 
   61: : testE ( "op" -- )
   62:     get-xt s1 evaluate
   63:     s" D_DIVIDEND N 1 DO  2dup I" evaluate xt @ compile,
   64:     s" drop LOOP 2drop ;" evaluate ; immediate
   65: 
   66: : testF ( "op" -- )
   67:     get-xt s1 evaluate
   68:     s" D_DIVIDEND N 1 DO  2dup 1 I" evaluate xt @ compile,
   69:     s" 2drop LOOP 2drop ;" evaluate ; immediate
   70: 
   71: \ The tests return the start time in ms
   72: 
   73: testA  /
   74: testA  MOD
   75: testB  /MOD
   76: testE  */
   77: testC  */MOD
   78: testC  FM/MOD
   79: testC  SM/REM
   80: testD  UM/MOD   ( testC causes overflow for UM/MOD )
   81: testF  M*/
   82: 9 table tests
   83: 
   84: : .elapsed ( starttime -- ) ms@ 9 emit swap - 4 .r ."  ms" ;
   85: 
   86: : run-tests
   87:     cr ." Speed Tests:"
   88:     9 0 DO  cr I cells tests + @ execute .elapsed LOOP cr ;
   89: 
   90: 
   91: run-tests

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>