Forth83 Benchmarks#

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

I found most of these benchmarks on comp.lang.forth, Hans Bzemers 4th and Marcel Hendrix benchmark collection

Results#

Benchme Helper#

: benchme ( xt n -- ) \ executes the word with the execution token 'xt' n-times
  dup >r              \ save number of iterations
  0 do dup execute loop \ execute word. word must have a neutral stack effect
  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#

This version uses a recursive call. Recursive calls are not standardized in early Forth systems. The word to call the current definition can have different names in your forth (recurse, self, ...). Please check you system documentation (if available) or the wordlist (using WORDS or VLIST).

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

Fibonacci 2#

: fib2 ( n1 -- n2 )                                                                
   0 1 rot 0 do 
      over + swap loop 
   drop ;
 
: fib2-bench 1000 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#

"BOUNDS" can be defined with:

( Convert str len to range for DO-loop )
: bounds ( str len -- str+len str )
  over + swap ;

"OFF" can be defined with:

( stores zero into address )
: OFF ( addr -- )
  0 SWAP ! ;

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

Sieve Benchmark#

FIG-Forth derived systems or Forth-79 Systems require the initial value of a variable on the stack.

So instead of "VARIABLE FLAGS 0 FLAGS !" use "0 VARIABLE FLAGS".

\ 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 ;  

"D0=" compares a double integer against zero. It can be defined as:

: D0= ( d d -- f )
  + 0= ;

\ 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) )

DECIMAL

 : 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 1000 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 ;