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