[UNDEFINED] CELL- [IF] : CELL- [ 1 CELLS ] LITERAL - ; [THEN] [UNDEFINED] -CELL [IF] -1 CELLS CONSTANT -CELL [THEN] ( * * LANGUAGE : ANS Forth + extensions * PROJECT : Forth Environments * DESCRIPTION : A Forth benchmark program * CATEGORY : Tools * AUTHOR : Stephen Pelc * LAST CHANGE : Wednesday, September 21, 2005, 21:04 PM, Marcel Hendrix * ) ( Forth Inc. benchmark tests adapted by Tom Zimmer, MPE, et. al. Other tests added by MPE. The application tests have been separated from the primitive tests. Constants have been declared and modified so that the runtimes of the application tests [Sieve, Fibonacci, QuickSort] can be made similar. The QuickSort test has been refactored to reduce the effect of the array initialisation, and this is tested in a separate test. Note that SwiftForth 2.0 includes special optimiser rules to eliminate some of the benchmark code! This is seen in the some of the primitive test results which are faster than the DO ... LOOP test. Note these of the word [o/n] whose job is to stop some optimising compilers from throwing away the multiply and divide operations. The implementation of [o/n] should lay a NOP opcode opcode on optimising systems, and may be an immediate NOOP on others ) DECIMAL \ ************************************************ \ Select system to be tested, set FORTHSYSTEM \ to value of selected target. \ Set SPECIFICS false to avoid system dependencies \ ************************************************ 1 CONSTANT PfwVfx \ MPE ProForth VFX 3.0 2 CONSTANT Pfw22 \ MPE ProForth 2.2 3 CONSTANT SwiftForth20 \ FI SwiftForth 2.0 4 CONSTANT SwiftForth15 \ FI SwiftForth 1.5 5 CONSTANT Win32Forth \ Win32Forth 3.5 6 CONSTANT iForth \ iForth 1.12 11 CONSTANT gforth-fast \ gforth-fast 0.6.9 s" gforth" environment? [if] 2drop gforth-fast CONSTANT ForthSystem \ works only on Gforth 0.6.9 [else] iforth CONSTANT ForthSystem [then] FALSE CONSTANT specifics \ true to use system dependent code TRUE CONSTANT ANSSYSTEM : .specifics \ -- ; display trick state ." using" specifics 0= IF ." no" THEN ." extensions" ; \ ******************** \ ProForth VFX harness \ ******************** PfwVfx ForthSystem = [IF] extern: DWORD PASCAL GetTickCount( void ) : COUNTER \ -- ms GetTickCount ; : >pos \ n -- ; step to position n out @ - SPACES ; : [o/n] \ -- POSTPONE [] ; IMMEDIATE [THEN] \ ******************** \ ProForth 2.2 harness \ ******************** Pfw22 ForthSystem = [IF] include valPFW22 : COUNTER \ -- ms WinGetTickCount ; : >pos \ n -- ; step to position n out @ - spaces ; : M/ \ d n1 -- quot m/mod nip ; : buffer: \ n -- ; -- addr create here over allot swap erase ; : m+ \ d n -- d' s>d d+ ; : [o/n] \ -- ; stop optimiser treating * DROP etc as no code ; immediate : SendMessage \ hwn msg wparam lparam -- result WinSendMessage ; [THEN] \ ******************** \ SwiftForth15 harness \ ******************** SwiftForth15 ForthSystem = [IF] : >pos \ n -- ; step to position n c# @ - spaces ; : [o/n] \ -- ; stop optimiser treating * DROP etc as no code ; immediate [THEN] \ ******************** \ SwiftForth20 harness \ ******************** SwiftForth20 ForthSystem = [IF] : >pos \ n -- ; step to position n get-xy drop - spaces ; : [o/n] \ -- ; stop optimiser treating * DROP etc as no code postpone noop ; immediate [THEN] \ ****************** \ Win32Forth harness \ ****************** Win32Forth ForthSystem = [IF] : COUNTER \ -- ms Call GetTickCount ; : >pos \ n -- ; step to position n getxy drop - spaces ; : M/ \ d n1 -- quot fm/mod nip ; : buffer: \ n -- ; -- addr create here over allot swap erase ; : 2- \ n -- n-2 2 - ; : [o/n] \ -- ; stop optimiser treating * DROP etc as no code ; immediate : SendMessage \ h m w l -- res swap 2swap swap \ Win32Forth uses reverse order Call SendMessage ; : GetTickCount \ -- ms Call GetTickCount ; [THEN] \ *************** \ iForth harness \ *************** iForth ForthSystem = [IF] 0 CONSTANT HWND_DESKTOP 1 CONSTANT WM_CLOSE : COUNTER ( -- ms ) ?MS ; : >pos ( n -- ) \ step to position n ?AT NIP AT-XY ; : buffer: ( n -- ) CREATE HERE OVER ALLOT SWAP ERASE DOES> ( -- addr ) ; \ stop optimiser treating * DROP etc as no code : [o/n] ( -- ) ; IMMEDIATE : SendMessage ( h m w l -- res ) DROP 2DROP ; [THEN] \ ************** \ gforth harness \ ************** gforth-fast ForthSystem = [IF] variable out \ -- addr : temit \ -- char 1 out +! (emit) ; ' temit is emit : ttype \ addr len -- dup out +! (type) ; ' ttype is type : cr \ -- cr out off ; : >pos \ n -- ; step to position n out @ - spaces ; decimal 0 CONSTANT U>D : counter \ -- ms cputime d+ 1000 um/mod nip ; create pocket 256 allot : c" \ -- [comp] ; -- addr [interp] state @ if postpone c" else [char] " parse pocket place pocket endif ; immediate : [o/n] ; IMMEDIATE : M/ \ d n1 -- quot sm/rem nip ; : buffer: \ n -- ; -- addr create here over allot swap erase ; : 2- \ n -- n-2 s" 2 -" evaluate ; immediate : u2/ \ u -- u' s" 1 RSHIFT" evaluate ; immediate : not \ x -- x' s" invert" evaluate ; immediate 0 constant HWND_DESKTOP 16 constant WM_CLOSE : SendMessage \ h m w l -- flag 2drop 2drop 0 ; [THEN] \ ************************************ \ FORTH, Inc. 64 Bit Benchmark Source \ ************************************ CR .( Loading benchmark routines) \ *********************** \ Benchmark support words \ *********************** \ column positions 40 CONSTANT time-pos 50 CONSTANT iter-pos 60 CONSTANT each-pos 70 CONSTANT extra-pos 4 CONSTANT #enhance : .header \ -- ; display test header CR ." Test time excluding overhead" time-pos 3 + >pos ." ms" iter-pos >pos ." times" each-pos >pos ." ns (each)" ; VARIABLE ms-elapsed VARIABLE totals : TIMER ( ms iterations -- ) #enhance / >R \ number of iterations COUNTER SWAP - #enhance / \ elapsed time in ms DUP ms-elapsed ! \ save for later DUP totals +! time-pos >pos DUP 5 .R iter-pos >pos R@ . R@ 1 > IF each-pos >pos #1000000 R> */ 5 .R ELSE DROP R> DROP THEN ; \ This .TOTALS does NOT include printing overhead (which can be huge!) : .totals time-pos >pos totals @ 5 .R ; : .ann \ -- banner announcement CR ; : [$ \ -- ms COUNTER ; \ $] is the suffix to a testing word. It takes the fast ticks \ timer value and calculates the elapsed time. It does do \ some display words before calculating the time, but it is \ assumed that this will take minimal time to execute. : $] ( n -- ) TIMER ; \ ****** \ Arrays \ ****** C" CARRAY" FIND NIP 0= [IF] \ CARRAY creates a byte size array. : CARRAY ( n -- ) CREATE ALLOT DOES> ( n -- a ) + ; [THEN] C" ARRAY" FIND NIP 0= [IF] \ ARRAY creates a cell size array. : ARRAY ( n -- ) CREATE CELLS ALLOT DOES> ( n -- a ) SWAP CELLS + ; [THEN] \ **************************** \ Basic FORTH, Inc. Benchmarks \ **************************** \ This series of tests analyzes the Forth primitives. #1000000 #enhance * CONSTANT /prims \ ( -- ) all these are stack neutral : $DO$ .ann ." DO LOOP" [$ /prims DUP 0 DO I [o/n] DROP LOOP $] ; : $*$ .ann ." *" [$ /prims DUP 0 DO I I * [o/n] DROP LOOP $] ; : $/$ .ann ." /" [$ /prims DUP 1+ 1 DO 1000 I / [o/n] DROP LOOP $] ; : $+$ .ann ." +" [$ /prims DUP 1+ 1 DO 1000 I + [o/n] DROP LOOP $] ; : $M*$ .ann ." M*" [$ /prims DUP 0 DO I I M* [o/n] 2DROP LOOP $] ; : $M/$ .ann ." M/" [$ /prims DUP 1+ 1 DO 1000 0 I M/ [o/n] DROP LOOP $] ; : $M+$ .ann ." M+" [$ /prims DUP 1+ 1 DO 1000 0 I M+ [o/n] 2DROP LOOP $] ; : $/MOD$ .ann ." /MOD" [$ /prims DUP 1+ 1 DO 1000 I /MOD [o/n] 2DROP LOOP $] ; : $*/$ .ann ." */" [$ /prims DUP 1+ 1 DO I I I */ [o/n] DROP LOOP $] ; \ **************************************** \ Eratosthanes sieve benchmark program \ This is NOT the original BYTE benchmark. \ **************************************** 8190 CONSTANT SIZE SIZE buffer: FLAGS VARIABLE =primes : DO-PRIME #1000 #enhance * 0 DO FLAGS SIZE 1 FILL 0 SIZE 0 DO FLAGS I + C@ IF I 2* 3 + DUP I + BEGIN DUP SIZE < WHILE DUP FLAGS + 0 SWAP C! OVER + REPEAT 2DROP 1+ ENDIF LOOP =primes ! LOOP ; : $SIEVE$ .ann ." Eratosthenes sieve " [$ DO-PRIME SIZE #1000 * #enhance * =primes @ . ." Primes" $] ; \ ******************* \ Fibonacci recursion \ ******************* #35 CONSTANT /fib : FIB ( n -- n' ) DUP 1 > IF DUP 1- RECURSE SWAP 2- RECURSE + THEN ; : $FIB$ .ann ." Fibonacci recursion ( " /fib DUP . ." -> " FIB . ." )" [$ 0 #enhance 0 DO DROP /fib FIB LOOP $] ; \ ********************************* \ QuickSort from Hoare & Wil Baden \ also contains the array fill test \ ********************************* 7 CELLS CONSTANT THRESHOLD : Precedes ( n n -- f ) < ; : Exchange ( a1 a2 -- ) 2DUP @ SWAP @ ROT ! SWAP ! ; : Both-Ends ( f l pivot -- f l ) >R BEGIN OVER @ R@ Precedes WHILE CELL 0 D+ REPEAT BEGIN R@ OVER @ Precedes WHILE CELL- REPEAT R> DROP ; : Order3 ( f l -- f l pivot ) 2DUP OVER - 2/ -CELL AND + >R DUP @ R@ @ Precedes IF DUP R@ Exchange THEN OVER @ R@ @ SWAP Precedes IF OVER R@ Exchange DUP @ R@ @ Precedes IF DUP R@ Exchange THEN THEN R> ; : Partition ( f l -- f l' f' l ) Order3 @ >R 2DUP CELL -CELL D+ BEGIN R@ Both-Ends 2DUP 1+ Precedes IF 2DUP Exchange CELL -CELL D+ THEN 2DUP SWAP Precedes UNTIL R> DROP SWAP ROT ; : Sink ( f key where -- f ) ROT >R BEGIN CELL- 2DUP @ Precedes WHILE DUP @ OVER CELL+ ! DUP R@ = IF ! R> EXIT THEN ( key where) REPEAT CELL+ ! R> ; : Insertion ( f l -- ) 2DUP Precedes IF CELL+ OVER CELL+ DO I @ I Sink CELL +LOOP DROP ELSE ( f l -- ) 2DROP THEN ; : Hoarify ( f l - ...) BEGIN 2DUP THRESHOLD 0 D+ Precedes WHILE Partition 2DUP - >R 2OVER - R> > IF 2SWAP THEN REPEAT Insertion ; : QUICK ( f l -- ) DEPTH >R BEGIN Hoarify DEPTH R@ < UNTIL R> DROP ; : SORT ( a n -- ) DUP 0= ABORT" Nothing to sort " 1- CELLS OVER + QUICK ; #10000 CONSTANT /array /array 1+ ARRAY pointers : fillp \ -- ; fill sort array once /array 0 ?DO /array I - I pointers ! LOOP ; : $FILL$ .ann ." ARRAY fill" [$ #100 #enhance * 0 DO fillp LOOP #100 #enhance * /array * $] ; : (sort) #100 #enhance * 0 DO fillp 0 pointers #10000 SORT LOOP ; : $SORT$ .ann ." Hoare's quick sort (reverse order) " [$ (sort) #100 #enhance * /array * $] ; \ ***************** \ "Random" Numbers \ ***************** 1024 CONSTANT /random VARIABLE ShiftRegister 1 ShiftRegister ! : RandBit \ -- 0..1 ; Generates a "random" bit. ShiftRegister @ 1 AND \ Gen result bit for this time thru. DUP 0<> \ Tap at position 31. ShiftRegister @ 8 AND 0<> \ Tap at position 28. XOR 0<> \ If the XOR of the taps is non-zero... $40000000 AND ShiftRegister @ 1 RSHIFT \ Shift register one bit right. OR \ OR in new left-hand bit. ShiftRegister ! ; \ Store new shift register value. CREATE lookup 0 , $40000000 , $40000000 , 0 , : RandBits \ n -- 0..2^(n-1) ; Generate an n-bit "random" number, n <= 32 0 SWAP 0 DO 2* ShiftRegister @ 1 AND OR \ this times' bit ShiftRegister @ 9 AND \ get two taps DUP 2 RSHIFT OR 3 AND \ $1001 -> $11 lookup SWAP CELLS + @ \ xor <> 0 -> $40000000 else 0 ShiftRegister @ 1 RSHIFT OR \ Shift register one bit right. \ OR in new left-hand bit. ShiftRegister ! \ Store new shift register value. LOOP ; CELL 8 * #64 = [IF] : MaxRandBits ( -- n ) #32 RandBits #32 LSHIFT #32 RandBits $FFFFFFFF AND OR ; [ELSE] : MaxRandBits ( -- n ) #32 RandBits ; [THEN] : (randtest) \ -- 1 ShiftRegister ! /random #1024 * ALLOCATE IF CR ." Failed to allocate " /random . ." kb for test" ABORT THEN #enhance 0 DO DUP /random #1024 * BOUNDS DO MaxRandBits I ! CELL +LOOP LOOP FREE DROP ; : $RAND$ .ann ." Generate random numbers (" /random . ." kb array)" [$ (randtest) /random #1024 * $] ; \ ********************************* \ LZ77 compression \ ********************************* 0 VALUE lz77-buffer 0 VALUE lz77-Pos 0 VALUE lz77-BytesLeft #400 CONSTANT /lz77-size : init-test-buffer /lz77-size #1024 * TO lz77-BytesLeft lz77-BytesLeft ALLOCATE IF CR ." Failed to allocate " /lz77-size . ." kb for test" ABORT THEN DUP TO lz77-buffer TO lz77-Pos lz77-buffer /lz77-size #1024 * BOUNDS DO MaxRandBits I ! CELL +LOOP ; : free-test-buffer lz77-buffer FREE DROP ; : getnextchar \ -- char true | false lz77-BytesLeft DUP IF DROP lz77-BytesLeft 1- TO lz77-BytesLeft lz77-Pos DUP 1+ TO lz77-Pos C@ TRUE THEN ; : LZ77-READ-FILE \ addr len fileid -- u2 ior DROP 0 -ROT 0 DO \ done addr -- getnextchar IF OVER C! 1+ SWAP 1+ SWAP ELSE LEAVE THEN LOOP DROP 0 ; : LZ77-WRITE-FILE \ addr len fileid -- ior DROP 2DROP 0 ; : closed DROP ; : checked \ flag -- ABORT" File Access Error. " ; : read-char \ file -- char DROP getnextchar 0= IF -1 ENDIF ; \ LZSS -- A Data Compression Program \ 89-04-06 Standard C by Haruhiko Okumura \ 94-12-09 Standard Forth by Wil Baden \ Use, distribute, and modify this program freely. #4096 CONSTANT N \ Size of Ring Buffer #18 CONSTANT F \ Upper Limit for match-length 2 CONSTANT eThreshold \ Encode string into position & length \ if match-length is greater. N CONSTANT Nil \ Index for Binary Search Tree Root VARIABLE textsize \ Text Size Counter VARIABLE printcount \ for debugging VARIABLE codesize \ Code Size Counter ( These are set by InsertNode procedure. ) VARIABLE match-position VARIABLE match-length N F + 1 - CARRAY text-buf \ Ring buffer of size N, with extra \ F-1 bytes to facilitate string comparison. \ Left & Right Children and Parents -- Binary Search Trees N 1 + ARRAY lson N #257 + ARRAY rson N 1 + ARRAY dad ( Input & Output Files ) 0 VALUE infile 0 VALUE outfile \ For i = 0 to N - 1, rson[i] and lson[i] will be the right and \ left children of node i. These nodes need not be initialized. \ Also, dad[i] is the parent of node i. These are initialized to \ Nil = N, which stands for `not used.' \ For i = 0 to 255, rson[N + i + 1] is the root of the tree \ for strings that begin with character i. These are initialized \ to Nil. Note there are 256 trees. ) ( Initialize trees. ) : InitTree ( -- ) N #257 + N 1+ DO Nil I rson ! LOOP N 0 DO Nil I dad ! LOOP ; \ Insert string of length F, text_buf[r..r+F-1], into one of the \ trees of text_buf[r]'th tree and return the longest-match position \ and length via the global variables match-position and match-length. \ If match-length = F, then remove the old node in favor of the new \ one, because the old one will be deleted sooner. \ Note r plays double role, as tree node and position in buffer. : InsertNode ( r -- ) Nil OVER lson ! Nil OVER rson ! 0 match-length ! DUP text-buf C@ N + 1+ ( r p) 1 ( r p cmp) BEGIN ( r p cmp) 0>= IF DUP rson @ Nil ( r p) <> IF rson @ ELSE 2DUP rson ! SWAP dad ! ( ) EXIT THEN ELSE DUP lson @ Nil ( r p) <> IF lson @ ELSE 2DUP lson ! SWAP dad ! ( ) EXIT THEN THEN ( r p) 0 F DUP 1 DO ( r p 0 F) 3 PICK I + text-buf C@ ( r p 0 F c) 3 PICK I + text-buf C@ - ( r p 0 F diff) ?DUP IF NIP NIP I LEAVE THEN ( r p 0 F) LOOP ( r p cmp i) DUP match-length @ > IF 2 PICK match-position ! DUP match-length ! F >= ELSE DROP FALSE THEN ( r p cmp flag ) UNTIL DROP ( r p ) 2DUP dad @ SWAP dad ! 2DUP lson @ SWAP lson ! 2DUP rson @ SWAP rson ! 2DUP lson @ dad ! 2DUP rson @ dad ! DUP dad @ rson @ OVER = IF TUCK dad @ rson ! ELSE TUCK dad @ lson ! THEN ( p) dad Nil SWAP ! ( Remove p ) ( ) ; ( Deletes node p from tree. ) : DeleteNode ( p -- ) DUP dad @ Nil = IF DROP EXIT THEN ( Not in tree. ) ( CASE ) ( p) DUP rson @ Nil = IF DUP lson @ ELSE DUP lson @ Nil = IF DUP rson @ ELSE DUP lson @ ( p q) DUP rson @ Nil = NOT IF BEGIN rson @ DUP rson @ Nil = UNTIL DUP lson @ OVER dad @ rson ! DUP dad @ OVER lson @ dad ! OVER lson @ OVER lson ! OVER lson @ dad OVER SWAP ! THEN OVER rson @ OVER rson ! OVER rson @ dad OVER SWAP ! ( ESAC ) THEN THEN ( p q) OVER dad @ OVER dad ! OVER DUP dad @ rson @ = IF OVER dad @ rson ! ELSE OVER dad @ lson ! THEN ( p) dad Nil SWAP ! ; ( ) 17 CARRAY code-buf VARIABLE len VARIABLE last-match-length VARIABLE code-buf-ptr VARIABLE mask : Encode ( -- ) 0 textsize ! 0 codesize ! InitTree ( Initialize trees. ) \ code_buf[1..16] saves eight units of code, and code_buf[0] \ works as eight flags, "1" representing that the unit is an \ unencoded letter in 1 byte, "0" a position-and-length pair \ in 2 bytes. Thus, eight units require at most 16 bytes \ of code. 0 0 code-buf C! 1 mask C! 1 code-buf-ptr ! 0 N F - ( s r) ( Clear the buffer with any character that will appear often. ) 0 text-buf N F - BL FILL ( Read F bytes into the last F bytes of the buffer. ) DUP text-buf F infile LZ77-READ-FILE checked ( s r count) DUP len ! DUP textsize ! 0= ?EXIT ( s r) ( Insert the F strings, each of which begins with one or more ( `space' characters. Note the order in which these strings ( are inserted. This way, degenerate trees will be less ( likely to occur. ) F 1 + 1 DO ( s r) DUP I - InsertNode LOOP ( Finally, insert the whole string just read. The ( global variables match-length and match-position are set. ) DUP InsertNode BEGIN ( s r) ( match_length may be spuriously long at end of text. ) match-length @ len @ > IF len @ match-length ! THEN match-length @ eThreshold <= IF ( Not long enough match. Send one byte. ) 1 match-length ! ( `send one byte' flag ) mask C@ 0 code-buf C@ OR 0 code-buf C! ( Send uncoded. ) DUP text-buf C@ code-buf-ptr @ code-buf C! 1 code-buf-ptr +! ELSE ( Send position and length pair. ( Note match-length > eThreshold. ) match-position @ code-buf-ptr @ code-buf C! 1 code-buf-ptr +! match-position @ 8 RSHIFT 4 LSHIFT ( . . j) match-length @ eThreshold - 1 - OR code-buf-ptr @ code-buf C! ( . .) 1 code-buf-ptr +! THEN ( Shift mask left one bit. ) ( . .) mask C@ 2* mask C! mask C@ 0= IF ( Send at most 8 units of code together. ) 0 code-buf code-buf-ptr @ ( . . a k) outfile LZ77-WRITE-FILE checked ( . .) code-buf-ptr @ codesize +! 0 0 code-buf C! 1 code-buf-ptr ! 1 mask C! THEN ( s r) match-length @ last-match-length ! last-match-length @ DUP 0 DO ( s r n) infile read-char ( s r n c) DUP 0< IF 2DROP I LEAVE THEN ( Delete old strings and read new bytes. ) 3 PICK DeleteNode DUP 4 PICK text-buf C! ( If the position is near end of buffer, extend ( the buffer to make string comparison easier. ) 3 PICK F 1- < IF ( s r n c) DUP 4 PICK N + text-buf C! THEN DROP ( s r n) \ Since this is a ring buffer, increment the \ position modulo N. >R >R ( s) 1+ N 1- AND R> ( s r) 1+ N 1- AND R> ( s r n) ( Register the string in text_buf[r..r+F-1]. ) OVER InsertNode LOOP ( s r i) DUP textsize +! \ textsize @ printcount @ > IF \ ( Report progress each time the textsize exceeds \ ( multiples of 1024. ) \ textsize @ 12 .R SPACE \ 1024 printcount +! \ THEN ( After the end of text, no need to read, but ( buffer may not be empty. ) last-match-length @ SWAP ?DO ( s r) OVER DeleteNode >R 1+ N 1- AND R> 1+ N 1- AND -1 len +! len @ IF DUP InsertNode THEN LOOP len @ 0<= UNTIL 2DROP ( Send remaining code. ) code-buf-ptr @ 1 > IF 0 code-buf code-buf-ptr @ outfile LZ77-WRITE-FILE checked code-buf-ptr @ codesize +! THEN ; : code77 \ -- init-test-buffer Encode free-test-buffer ; : $CODE77$ .ann ." LZ77 Comp. (" /lz77-size . ." kb Random Data Mem>Mem)" [$ #enhance 0 DO code77 LOOP #enhance $] ; \ ********************************************* \ DHRYSTONE integer benchmark by Marcel Hendrix \ ********************************************* 0 [IF] "DHRYSTONE" Benchmark Program Version: Forth/1 Date: 05/03/86 Author: Reinhold P. Weicker, CACM Vol 27, No 10, 10/84 pg. 1013 C version translated from ADA by Rick Richardson. Every method to preserve ADA-likeness has been used, at the expense of C-ness. Modula-2 version translated from C by Kevin Northover. Again every attempt made to avoid distortions of the original. Forth version translated from Modula-2 by Marcel Hendrix. Distorting the original was inevitable, given the differences between a strongly typed and a user-extensible language. Moreover, there is serious doubt of the instruction mix being appropriate for Forth. The following program contains statements of a high-level programming language (Forth) in a distribution considered representative: statements 53% control statements 32% procedures, function calls 15% 100 statements are dynamically executed. The program is balanced with respect to the three aspects: - statement type - operand type (for simple data types) - operand access operand global, local parameter, or constant. The combination of these three aspects is balanced only approximately. The program does not compute anything meaningful, but it is syntactically and semantically correct. The source code was "pre-optimized" on a word-to-word basis with the programmer acting as a pre-processor to the compiler. Real Forth programmers would rather be found dead than write disgusting programs like this. If you understand what both DHRYSTON.C and DHRYSTON.FRT are doing, you'll never trust a benchmark again. [THEN] ANSSYSTEM [IF] DECIMAL \ -- Control human fatigue factor #500000 #enhance * VALUE LOOPS \ -- Some types 1 CONSTANT Ident1 2 CONSTANT Ident2 3 CONSTANT Ident3 4 CONSTANT Ident4 5 CONSTANT Ident5 0 CONSTANT NUL CREATE Array1Glob 50 CELLS ALLOT CREATE Array2Glob 50 DUP * CELLS ALLOT \ -- Some obvious macro's : []Array1Par S" CELLS Array1Par + " EVALUATE ; IMMEDIATE : [][]Array2Par S" 50 * + CELLS Array2Par + " EVALUATE ; IMMEDIATE : ADDRESS ; IMMEDIATE 0 VALUE /bytes : RECORD CREATE 0 TO /bytes HERE 0 , ( -- sys ) DOES> @ ALLOCATE THROW ; ( -- addr ) : ENDS /bytes SWAP ! ; ( sys -- ) : SIMPLE-TYPE CREATE , ( fieldlength -- ) DOES> @ CREATE IMMEDIATE /bytes , /bytes + TO /bytes DOES> @ POSTPONE LITERAL ( 'record -- 'offset ) POSTPONE + ; 1 CELLS SIMPLE-TYPE RecordPtr 1 CELLS SIMPLE-TYPE Enumeration \ one of Ident1 .. Ident5 1 CELLS SIMPLE-TYPE OneToFifty 31 CHARS SIMPLE-TYPE String30 \ extra count byte RECORD RecordType \ offset RecordPtr PtrComp \ 0 Enumeration Discr \ 1 CELLS Enumeration EnumComp \ 2 CELLS OneToFifty IntComp \ 3 CELLS String30 StringComp \ 4 CELLS ENDS \ -- Some global variables 0 VALUE IntGlob 0 VALUE BoolGlob 0 VALUE Char1Glob 0 VALUE Char2Glob 0 VALUE p^ NUL VALUE PtrGlb NUL VALUE PtrGlbNext HERE ," DHRYSTONE PROGRAM, SOME STRING" CONSTANT str1 HERE ," DHRYSTONE PROGRAM, 2'ND STRING" CONSTANT str2 : Proc7 + 2 + ; ( n1 n2 -- n3 ) : Proc3 PtrGlb IF PtrGlb PtrComp @ ( 'record -- ) SWAP ! ELSE DROP #100 TO IntGlob THEN 10 IntGlob Proc7 PtrGlb IntComp ! ; : Func3 Ident3 = ; : Proc6 ( n1 n2 -- n ) OVER LOCALS| n n2 n1 | n1 Func3 0= IF Ident4 TO n THEN CASE n1 Ident1 OF Ident1 ENDOF Ident2 OF IntGlob 100 > IF Ident1 ELSE Ident4 THEN ENDOF Ident3 OF Ident2 ENDOF Ident4 OF n ENDOF Ident5 OF Ident3 ENDOF ABORT" Proc6: argument out of range" DROP ENDCASE ; : Proc1 ( 'record -- ) TO p^ PtrGlb p^ PtrComp ! 5 p^ IntComp ! p^ IntComp @ p^ PtrComp @ IntComp ! p^ PtrComp @ p^ PtrComp @ PtrComp @ ! p^ PtrComp @ PtrComp @ Proc3 p^ PtrComp @ Discr @ Ident1 = IF 6 p^ PtrComp @ IntComp ! p^ PtrComp @ EnumComp p^ EnumComp @ OVER @ Proc6 SWAP ! PtrGlb PtrComp p^ PtrComp @ PtrComp ! p^ PtrComp @ IntComp DUP @ 10 Proc7 SWAP ! ELSE p^ PtrComp @ p^ ! THEN ; : Proc2 ( val -- val' ) DUP #10 + >R \ "IntLoc" BEGIN Char1Glob 'A' = \ This one never ends WHILE R> 1- >R ( dec IntLoc ) \ unless Char <> 'A' ?? DROP R@ ( IntLoc ) IntGlob - TRUE UNTIL THEN R> DROP ; : Proc4 'B' TO Char2Glob ; : Proc5 'A' TO Char1Glob FALSE TO BoolGlob ; : Proc8 ( 'array1 'array2 n1 n2 -- ) SWAP 5 + LOCALS| IntLoc IntParI2 Array2Par Array1Par | IntLoc []Array1Par IntParI2 OVER ! ( addr) @ IntLoc 1+ []Array1Par ! IntLoc DUP 30 + []Array1Par ! IntLoc DUP DUP [][]Array2Par ! IntLoc DUP DUP 1+ [][]Array2Par ! 1 IntLoc DUP 1- [][]Array2Par +! IntLoc []Array1Par @ IntLoc DUP #20 + SWAP [][]Array2Par ! 5 TO IntGlob ; : Func1 ( char1 char2 -- n ) = IF Ident2 ELSE Ident1 THEN ; : Func2 ( '$1 '$2 -- bool ) 2 BL LOCALS| CharLoc IntLoc '$2 '$1 | BEGIN IntLoc 2 <= WHILE IntLoc 1+ '$1 + C@ IntLoc 2 + '$2 + C@ Func1 Ident1 = IF 'A' TO CharLoc IntLoc 1+ TO IntLoc THEN REPEAT CharLoc 'W' >= IF CharLoc 'Z' <= IF 7 TO IntLoc THEN THEN \ dead code, IntLoc never used! CharLoc 'X' = IF TRUE EXIT THEN FALSE '$1 COUNT '$2 COUNT COMPARE 0> IF 7 IntLoc + TO IntLoc INVERT \ dead code, IntLoc is local THEN ; \ Proc0 is 100% dependent on the speed of CMOVE ! : Proc0 #31 ALLOCATE THROW #31 ALLOCATE THROW 0 0 0 0 0 0 \ The following must be on ONE line or Win32Forth will crash. LOCALS| CharIndex CharLoc EnumLoc IntLoc3 IntLoc2 IntLoc1 String2Loc String1Loc | \ constructors, allocate RecordType TO PtrGlb RecordType TO PtrGlbNext PtrGlbNext PtrGlb PtrComp ! Ident1 PtrGlb Discr ! Ident3 PtrGlb EnumComp ! #40 PtrGlb IntComp ! str1 DUP C@ 1+ PtrGlb StringComp SWAP CMOVE LOOPS 0 DO Proc5 Proc4 2 TO IntLoc1 3 TO IntLoc2 str2 DUP C@ 1+ String2Loc SWAP CMOVE Ident2 TO EnumLoc String1Loc String2Loc Func2 INVERT TO BoolGlob BEGIN IntLoc1 IntLoc2 < WHILE IntLoc1 5 * IntLoc2 - TO IntLoc3 IntLoc1 IntLoc2 Proc7 TO IntLoc3 \ The Forth way IntLoc1 1+ TO IntLoc1 REPEAT ADDRESS Array1Glob ADDRESS Array2Glob IntLoc1 IntLoc2 Proc8 PtrGlb Proc1 'A' TO CharIndex BEGIN CharIndex Char2Glob <= WHILE CharIndex 'C' Func1 EnumLoc = IF Ident1 EnumLoc Proc6 TO EnumLoc THEN CharIndex 1+ TO CharIndex REPEAT IntLoc1 IntLoc2 * TO IntLoc3 IntLoc3 IntLoc1 / TO IntLoc2 IntLoc3 IntLoc2 - 7 * IntLoc1 - TO IntLoc2 IntLoc1 Proc2 TO IntLoc1 \ the Forth way LOOP PtrGlb FREE THROW PtrGlbNext FREE THROW String1Loc FREE THROW String2Loc FREE THROW ; : $DHRY$ \ -- .ann ." Dhrystone (integer)" [$ Proc0 LOOPS $] extra-pos >pos LOOPS #1000 ms-elapsed @ #enhance * 1 MAX */ U>D D. ." Dhrystones/sec" ; [THEN] \ ******************* \ API Call OverHead \ ******************* HWND_DESKTOP VALUE hWnd #4000 #enhance * CONSTANT /api1 : (api1) \ -- ; SENDMESSAGE is probably the most used API function there is! hWnd WM_CLOSE 0 0 SendMessage DROP ; : $API1$ \ -- .ann ." Win32 API: SendMessage" [$ /api1 0 DO (api1) LOOP /api1 $] ; #100000 #enhance * CONSTANT /api2 : $API2$ \ -- .ann ." Win32 API: GetTickCount" [$ /api2 0 DO COUNTER DROP LOOP /api2 $] ; \ ************************* \ The main benchmark driver \ ************************* : BENCHMARK .ann ." This system's primitives" .specifics CR .header totals OFF $DO$ $+$ $M+$ $*$ $/$ $M*$ $M/$ $/MOD$ $*/$ $FILL$ CR ." Total:" .totals CR .ann ." This system's O/S interface" .specifics CR .header totals OFF $API1$ $API2$ CR ." Total:" .totals CR .ann ." This system's application performance" .specifics CR .header totals OFF $SIEVE$ $FIB$ $SORT$ $RAND$ $CODE77$ $DHRY$ CR ." Total:" .totals ; CR CR .( To run the benchmark program, type BENCHMARK ) 0 [IF] (* This system's primitives using no extensions ( 3.1 March 2 2007 ) Test time excluding overhead ms times ns (each) DO LOOP 5 1000000 5 + 7 1000000 7 M+ 24 1000000 24 * 6 1000000 6 / 40 1000000 40 M* 21 1000000 21 M/ 55 1000000 55 /MOD 40 1000000 40 */ 53 1000000 53 ARRAY fill 200 1000000 200 Total: 451 This system's O/S interface using no extensions Test time excluding overhead ms times ns (each) Win32 API: SendMessage 3 4000 750 Win32 API: GetTickCount 190 100000 1900 Total: 193 This system's application performance using no extensions Test time excluding overhead ms times ns (each) Eratosthenes sieve 1899 Primes 1208 8190000 147 Fibonacci recursion ( 35 -> 9227465 ) 823 9227465 89 Hoare's quick sort (reverse order) 972 1000000 972 Generate random numbers (1024 kb array) 1428 262144 5447 LZ77 Comp. (400 kb Random Data Mem>Mem) 13590 1 Dhrystone (integer) 21328 500000 42656 23,443 Dhrystones/sec Total: 39349 ok This system's primitives using no extensions ( 3.1 March 3, 2007 ) Test time excluding overhead ms times ns (each) DO LOOP 4 1000000 4 + 8 1000000 8 M+ 24 1000000 24 * 6 1000000 6 / 40 1000000 40 M* 21 1000000 21 M/ 55 1000000 55 /MOD 40 1000000 40 */ 53 1000000 53 ARRAY fill 69 1000000 69 Total: 320 This system's O/S interface using no extensions Test time excluding overhead ms times ns (each) Win32 API: SendMessage 1 4000 250 Win32 API: GetTickCount 179 100000 1790 Total: 180 This system's application performance using no extensions Test time excluding overhead ms times ns (each) Eratosthenes sieve 1899 Primes 909 8190000 110 Fibonacci recursion ( 35 -> 9227465 ) 1005 9227465 108 Hoare's quick sort (reverse order) 1423 1000000 1423 Generate random numbers (1024 kb array) 776 262144 2960 LZ77 Comp. (400 kb Random Data Mem>Mem) 6532 1 Dhrystone (integer) 2194 500000 4388 227,894 Dhrystones/sec Total: 12839 ok This system's primitives using no extensions ( 3.2 March 18, 2007 ) Test time excluding overhead ms times ns (each) DO LOOP 4 1000000 4 + 7 1000000 7 M+ 25 1000000 25 * 6 1000000 6 / 39 1000000 39 M* 21 1000000 21 M/ 55 1000000 55 /MOD 39 1000000 39 */ 55 1000000 55 ARRAY fill 36 1000000 36 Total: 287 This system's O/S interface using no extensions Test time excluding overhead ms times ns (each) Win32 API: SendMessage 1 4000 250 Win32 API: GetTickCount 194 100000 1940 Total: 195 This system's application performance using no extensions Test time excluding overhead ms times ns (each) Eratosthenes sieve 1899 Primes 715 8190000 87 Fibonacci recursion ( 35 -> 9227465 ) 602 9227465 65 Hoare's quick sort (reverse order) 772 1000000 772 Generate random numbers (1024 kb array) 907 262144 3459 LZ77 Comp. (400 kb Random Data Mem>Mem) 4923 1 Dhrystone (integer) 2276 500000 4552 219,683 Dhrystones/sec Total: 10195 ok This system's primitives using no extensions ( vsn 5.3 ) Test time excluding overhead ms times ns (each) DO LOOP 3 1000000 3 + 3 1000000 3 M+ 3 1000000 3 * 3 1000000 3 / 35 1000000 35 M* 3 1000000 3 M/ 35 1000000 35 /MOD 36 1000000 36 */ 37 1000000 37 ARRAY fill 18 1000000 18 Total: 176 This system's O/S interface using no extensions Test time excluding overhead ms times ns (each) Win32 API: SendMessage 0 4000 0 Win32 API: GetTickCount 174 100000 1740 Total: 174 This system's application performance using no extensions Test time excluding overhead ms times ns (each) Eratosthenes sieve 1899 Primes 166 8190000 20 Fibonacci recursion ( 35 -> 9227465 ) 255 307582 829 Hoare's quick sort (reverse order) 142 1000000 142 Generate random numbers (1024 kb array) 107 8738 12245 LZ77 Comp. (400 kb Random Data Mem>Mem) 519 1 Dhrystone (integer) 153 500000 306 3,267,973 Dhrystones/sec Total: 1342 ok This system's primitive using no extensions ( 7.1 inline, only 2 colon-fixes ) Test time excluding overhead ms times ns (each) DO LOOP 2 1000000 2 + 3 1000000 3 M+ 2 1000000 2 * 2 1000000 2 / 3 1000000 3 M* 2 1000000 2 M/ 2 1000000 2 /MOD 31 1000000 31 */ 2 1000000 2 ARRAY fill 4 1000000 4 Total: 53 This system's O/S interface using no extensions Test time excluding overhead ms times ns (each) Win32 API: SendMessage 0 4000 0 Win32 API: GetTickCount 171 100000 1710 Total: 171 This system's application performance using no extensions Test time excluding overhead ms times ns (each) Eratosthenes sieve 1899 Primes 121 8190000 14 Fibonacci recursion ( 35 -> 9227465 ) 247 307582 803 Hoare's quick sort (reverse order) 82 1000000 82 Generate random numbers (1024 kb array) 97 8738 11100 LZ77 Comp. (400 kb Random Data Mem>Mem) 490 1 Dhrystone (integer) 142 500000 284 3,521,126 Dhrystones/sec Total: 1179 ok This system's primitives using no extensions ( vsn 7.2 ) Test time excluding overhead ms times ns (each) DO LOOP 2 1000000 2 + 3 1000000 3 M+ 2 1000000 2 * 2 1000000 2 / 2 1000000 2 M* 3 1000000 3 M/ 2 1000000 2 /MOD 3 1000000 3 */ 2 1000000 2 ARRAY fill 3 1000000 3 Total: 24 This system's O/S interface using no extensions Test time excluding overhead ms times ns (each) Win32 API: SendMessage 0 4000 0 Win32 API: GetTickCount 170 100000 1700 Total: 170 This system's application performance using no extensions Test time excluding overhead ms times ns (each) Eratosthenes sieve 1899 Primes 123 8190000 15 Fibonacci recursion ( 35 -> 9227465 ) 204 307582 663 Hoare's quick sort (reverse order) 113 1000000 113 Generate random numbers (1024 kb array) 77 34952 2203 LZ77 Comp. (400 kb Random Data Mem>Mem) 131 1 Dhrystone (integer) 132 500000 264 3,787,878 Dhrystones/sec Total: 780 ok FORTH> SwiftForth 3.0.7 09-Feb-2007 cd C:\ForthInc\swiftforth\lib\Samples\irc ok INCLUDE "C:\ForthInc\SwiftForth\Lib\Samples\benchmrk.fth" Benchmark code size 131022 bytes. This system's primitives using no extensions and using no hackery Test time including overhead ms times ns (each) DO LOOP 0 1000000 0 + 0 1000000 0 M+ 16 1000000 16 * 0 1000000 0 / 31 1000000 31 M* 0 1000000 0 M/ 15 1000000 15 /MOD 16 1000000 16 */ 16 1000000 16 ARRAY fill 31 1000000 31 Total: 125 1 This system's O/S interface using no extensions and using no hackery Test time including overhead ms times ns (each) Win32 API: SendMessage 31 40000 775 Win32 API: COUNTER 0 100000 0 System I/O: KEY? 547 40000 13675 Total: 578 1 This system's application performance using no extensions and using no hackery Test time including overhead ms times ns (each) Eratosthenes sieve 1899 Primes 156 8190000 19 Fibonacci recursion ( 35 -> 9227465 ) 157 9227430 17 Hoare's quick sort (reverse order) 156 2000000 78 Generate random numbers (1024 kb array) 1062 262144 4051 LZ77 Comp. (400 kb Random Data Mem>Mem) 1313 1 Dhrystone (integer) 265 500000 530 1886792 Dhrystones/sec Total: 3109 1 This system's primitives using no extensions ( eForth 7.2 on AMD X2 3 GHz ) Test time excluding overhead ms times ns (each) DO LOOP 2 1000000 2 + 2 1000000 2 M+ 1 1000000 1 * 2 1000000 2 / 2 1000000 2 M* 2 1000000 2 M/ 1 1000000 1 /MOD 2 1000000 2 */ 1 1000000 1 ARRAY fill 2 1000000 2 Total: 17 This system's O/S interface using no extensions Test time excluding overhead ms times ns (each) Win32 API: SendMessage 0 4000 0 Win32 API: GetTickCount 117 100000 1170 Total: 117 This system's application performance using no extensions Test time excluding overhead ms times ns (each) Eratosthenes sieve 1899 Primes 71 8190000 8 Fibonacci recursion ( 35 -> 9227465 ) 161 307582 523 Hoare's quick sort (reverse order) 75 1000000 75 Generate random numbers (1024 kb array) 49 34952 1401 LZ77 Comp. (400 kb Random Data Mem>Mem) 96 1 Dhrystone (integer) 95 500000 190 5,263,157 Dhrystones/sec Total: 547 ok This system's primitives using no extensions ( iForth 2.0 on 3 GHz AMD X2 ) Test time excluding overhead ms times ns (each) DO LOOP 2 1000000 2 + 2 1000000 2 M+ 2 1000000 2 * 2 1000000 2 / 16 1000000 16 M* 2 1000000 2 M/ 16 1000000 16 /MOD 16 1000000 16 */ 17 1000000 17 ARRAY fill 3 1000000 3 Total: 78 This system's O/S interface using no extensions Test time excluding overhead ms times ns (each) Win32 API: SendMessage 0 4000 0 Win32 API: GetTickCount 124 100000 1240 Total: 124 This system's application performance using no extensions Test time excluding overhead ms times ns (each) Eratosthenes sieve 1899 Primes 61 8190000 7 Fibonacci recursion ( 35 -> 9227465 ) 176 307582 572 Hoare's quick sort (reverse order) 44 1000000 44 Generate random numbers (1024 kb array) 49 34952 1401 LZ77 Comp. (400 kb Random Data Mem>Mem) 81 1 Dhrystone (integer) 65 500000 130 7,692,307 Dhrystones/sec Total: 476 ok *) [THEN]