!!!Forth83 Benchmarks

Below is a collection of some Benchmarks for Forth83 systems like VolksForth.

I found most of these benchmarks on [comp.lang.forth|http://groups.google.com/group/comp.lang.forth], [Hans Bzemers|http://thebeezspeaks.blogspot.com/] [4th|http://www.xs4all.nl/~thebeez/4tH/foldtree.html] and Marcel Hendrix [benchmark collection|http://home.iae.nl/users/mhx/monsterbench.html]

[{TableOfContents }]

!! Benchme Helper

{{{
: beep ( -- ) \ emits an audible beep signal
  7 con! ;    \ this is hardware and implementation dependent
 
: benchme ( xt n -- ) \ executes the word with the execution token 'xt' n-times
  dup >r              \ save number of iterations
  beep                \ signal of benchmark start
  0 do dup execute loop \ execute word. word must have a neutral stack effect
  beep                \ signal benchmark end
  cr r> . ." Iterations." cr \ emit message
;
}}}   
  

!!Integer Calculations 

{{{
32000 constant intMax

variable intResult

: DoInt
  1 dup intResult dup >r !
  begin
    dup intMax <
  while
    dup negate r@ +! 1+
    dup r@ +! 1+
    r@ @ over * r@ ! 1+
    r@ @ over / r@ ! 1+
  repeat
  r> drop drop
;
}}}

!!Fibonacci 1

{{{
: fib1 ( n1 -- n2 )
    dup 2 < if drop 1 exit then
    dup  1- recursive 
    swap 2- recursive  + ;
    
: fib1-bench 10000 0 do i fib1 drop loop ;

}}}

!!Fibonacci 2

{{{
: fib2 ( n1 -- n2 )                                                                
   dup 2 < if drop 1 else                                                           
   dup  1- recursive                                                                
   swap 2 - recursive +                                                             
 then ;   

: fib2-bench 10000 0 do i fib2 drop loop ;

}}}


!!Forth Nesting Benchmark

{{{
 \ Forth nesting (NEXT) Benchmark                     cas20101204                   
 : bottom ;                                                                         
 : 1st bottom bottom ;  : 2nd 1st 1st ;      : 3rd 2nd 2nd ;                        
 : 4th 3rd 3rd ;        : 5th 4th 4th ;      : 6th 5th 5th ;                        
 : 7th 6th 6th ;        : 8th 7th 7th ;      : 9th 8th 8th ;                        
 : 10th 9th 9th ;       : 11th 10th 10th ;   : 12th 11th 11th ;                     
 : 13th 12th 12th ;     : 14th 13th 13th ;   : 15th 14th 14th ;                     
 : 16th 15th 15th ;     : 17th 16th 16th ;   : 18th 17th 17th ;                     
 : 19th 18th 18th ;     : 20th 19th 19th ;   : 21th 20th 20th ;                     
 : 22th 21th 21th ;     : 23th 22th 22th ;   : 24th 23th 23th ;                     
 : 25th 24th 24th ;                                                                 
                                                                                    
 : 32million   CR ." 32 million nest/unnest operations" 25th ;                      
 :  1million   CR ."  1 million nest/unnest operations" 20th ;                      
                                                                                    
 CR .( enter 1million or 32million )         
}}}

!!Forth Memory Move Benchmark
{{{
\ Forth Memory Move Benchmark                       cas 20101204                   
  8192 CONSTANT bufsize                                                             
 VARIABLE buf1 HERE bufsize 1+ allot BUF1 !                                         
 VARIABLE buf2 HERE bufsize 1+ allot BUF2 !                                         
                                                                                    
 : test-CMOVE 49 0 DO BUF1 @ BUF2 @ bufsize CMOVE LOOP ;                            
                                                                                    
 : test-CMOVE> 49 0 DO BUF2 @ BUF1 @ bufsize CMOVE> LOOP ;                          
                                                                                    
 : test-MOVE> 49 0 DO BUF1 @ BUF2 @ bufsize MOVE LOOP ;                             
                                                                                    
 : test-<MOVE 49 0 DO BUF2 @ BUF1 @ bufsize MOVE LOOP ;     
 
 : move-bench test-CMOVE test-CMOVE> test-MOVE> test-<MOVE ;
}}}

!!count bits in byte

{{{
 \ Forth Benchmark - count bits in byte              cas 20101204
 
 VARIABLE cnt
 
 : countbits ( uu -- #bits )
   cnt off
   8 0 DO dup $01010101  and cnt +!
          2/
   LOOP drop
   0 cnt 4 bounds DO i C@ + LOOP ;
 
 : bench5
   8192 DO I countbits . LOOP ;
}}}

!!Sieve Benchmark

{{{
\ Sieve Benchmark -- the classic Forth benchmark    cas 20101204                   
                                                                                    
 8192 CONSTANT SIZE   VARIABLE FLAGS  0 FLAGS !  SIZE ALLOT                         
                                                                                    
 : DO-PRIME                                                                         
   FLAGS SIZE 1 FILL  ( set array )                                                 
   0 ( 0 COUNT ) SIZE 0                                                             
   DO FLAGS I + C@                                                                  
     IF I DUP + 3 + DUP I +                                                         
        BEGIN DUP SIZE <                                                            
        WHILE 0   OVER FLAGS +  C!  OVER +  REPEAT                                  
        DROP DROP 1+                                                                
     THEN                                                                           
 LOOP                                                                               
 . ." Primes" CR ;        
}}}

!!Greatest Common Divisor

{{{
\ gcd - greatest common divisor                     cas 20101204                   
                                                                                    
 : gcd ( a b -- gcd )                                                               
   OVER IF                                                                          
     BEGIN                                                                          
       DUP WHILE                                                                    
          2DUP U> IF SWAP THEN OVER -                                               
     REPEAT DROP ELSE                                                               
     DUP IF NIP ELSE 2DROP 1 THEN                                                   
   THEN ;  
   
: gcd1-bench 100 0 DO 
      100 0 DO j i gcd drop loop
      loop ;  
}}}

{{{
\ another gcd O(2) runtime speed                    cas 20101204                   
                                                                                    
 : gcd2 ( a b -- gcd )                                                              
   2DUP        D0= IF  2DROP 1 EXIT   THEN                                          
   DUP          0= IF   DROP   EXIT   THEN                                          
   SWAP DUP     0= IF   DROP   EXIT   THEN                                          
   BEGIN  2DUP -                                                                    
   WHILE  2DUP < IF OVER -                                                          
                 ELSE SWAP OVER - SWAP                                              
                 THEN                                                               
   REPEAT NIP ;          

: gcd2-bench 100 0 DO 
      100 0 DO j i gcd2 drop loop
      loop ;  
}}}

!!Takeuchi
{{{
( takeuchi benchmark in volksForth Forth-83 )
( see http://en.wikipedia.org/wiki/Tak_(function) )

 : 3dup 2 pick 2 pick 2 pick ;                                                        

 : tak ( x y z -- t )                                                                 
   over 3 pick < NEGATE IF nip nip exit then                                          
   3dup rot 1- -rot recursive >r                                                      
   3dup swap 1- -rot swap recursive >r                                                
             1- -rot recursive                                                        
   r> swap r> -rot recursive ;                                                        
                                                                                      
 : takbench ( -- )                                                                    
   0 &10000 0 DO DROP &18 &12 6 tak LOOP ;                                            
                                                    
}}}

!!simple 6502 emulator
{{{
\ A simple 6502 emulattion benchmark                         cas                     
\ only 11 opcodes are implemented. The memory layout is:                             
\  2kB RAM at 0000-07FF, mirrored throughout 0800-7FFF                               
\ 16kB ROM at 8000-BFFF, mirrored at C000                                            
decimal                                                                              
create ram 2048 allot   : >ram $7FF  and ram + ;                                     
create rom 16384 allot  : >rom $3FFF and rom + ;                                     
\ 6502 registers                                                                     
variable reg-a   variable reg-x  variable reg-y                                      
variable reg-s   variable reg-pc  : reg-pc+ reg-pc +! ;                              
\ 6502 flags                                                                         
variable flag-c  variable flag-n   variable cycle                                    
variable flag-z  variable flag-v  : cycle+ cycle +! ;                                
hex                                                                                  
: w@ dup c@ swap 1+ c@ 100 * or ;                                                    
: cs@ c@ dup 80 and if 100 - then ;        

: read-byte ( address -- )                                                           
  dup 8000 < if >ram c@ else >rom c@ then ;                                          
: read-word ( address -- )                                                           
  dup 8000 < if >ram w@ else >rom w@ then ;                                          
: dojmp ( JMP aaaa )                                                                 
  reg-pc @ >rom w@ reg-pc ! 3 cycle+ ;                                               
: dolda ( LDA aa )                                                                   
  reg-pc @ >rom c@ ram + c@ dup dup reg-a !                                          
  flag-z ! 80 and flag-n ! 1 reg-pc+ 3 cycle+ ;                                      
: dosta ( STA aa )                                                                   
  reg-a @ reg-pc @ >rom c@ ram + c! 1 reg-pc+ 3 cycle+ ;                             
: dobeq ( BEQ <aa )                                                                  
  flag-z @ 0= if reg-pc @ >rom cs@ 1+ reg-pc+ else 1 reg-pc+ then 3 cycle+ ;   
: doldai ( LDA #aa )                                                                 
  reg-pc @ >rom c@ dup dup reg-a ! flag-z ! 80 and flag-n !                          
  1 reg-pc+ 2 cycle+ ;                                                               
: dodex ( DEX )                                                                      
  reg-x @ 1- FF and dup dup reg-x ! flag-z ! 80 and flag-n !                         
  2 cycle+ ;                                                                         
: dodey ( DEY )                                                                      
  reg-y @ 1- ff and dup dup reg-y ! flag-z ! 80 and flag-n !                         
  2 cycle+ ;                                                                         
: doinc ( INC aa )                                                                   
  reg-pc @ >rom c@ ram + dup c@ 1+ FF and dup -rot swap c! dup                       
  flag-z ! 80 and flag-n !  1 reg-pc+ 3 cycle+ ;                                     
: doldy ( LDY aa )                                                                   
  reg-pc @ >rom c@ dup dup reg-y ! flag-z ! 80 and flag-n !                          
  1 reg-pc+ 2 cycle+ ; 
: doldx ( LDX #aa )                                                                  
  reg-pc @ >rom c@ dup dup reg-x ! flag-z ! 80 and flag-n !                          
  1 reg-pc+ 2 cycle+ ;                                                               
: dobne ( BNE <aa )                                                                  
  flag-z @ if reg-pc @ >rom cs@ 1+ reg-pc+ else 1 reg-pc+ then                       
  3 cycle+ ;                                                                         
: 6502emu ( cycles -- )                                                              
  begin cycle @ over  < while                                                        
    reg-pc @ >rom c@ 1 reg-pc+                                                       
    dup 4C = if dojmp then      dup A5 = if dolda then                               
    dup 85 = if dosta then      dup F0 = if dobeq then                               
    dup D0 = if dobne then      dup A9 = if doldai then                              
    dup CA = if dodex then      dup 88 = if dodey then                               
    dup E6 = if doinc then      dup A0 = if doldy then                               
        A2 = if doldx then      repeat drop ; 

create testcode                                                                      
  A9 c, 00 c,  \ start: LDA #0                                                       
  85 c, 08 c,  \        STA 08                                                       
  A2 c, 0A c,  \        LDX #10                                                      
  A0 c, 0A c,  \ loop1: LDY #10                                                      
  E6 c, 08 c,  \ loop2: INC 08                                                       
  88 c,        \        DEY                                                          
  D0 c, FB c,  \        BNE loop2                                                    
  CA c,        \        DEX                                                          
  D0 c, F6 c,  \        BNE loop1                                                    
  4C c, 00 c, 80 C, \   JMP start 
                                                     
: init-vm 13 0 do i testcode + c@ i rom + c! loop                                    
          0 cycle ! 8000 reg-pc ! ;                                                  

: bench6502 100 0 do init-vm &6502 6502emu loop ;
}}}