#! /usr/local/bin/f8 ss
also compiler call-by-disp previous
also ans [DEFINED] loctest 0= [IF]  -1 =: loctest [THEN] previous
cr
\ @(#) bench.fth 97/12/10 1.1
\ Benchmark Forth
\ by Phil Burk
\ 11/17/95
\
\ pForthV9 on Indy, compiled with gcc
\  bench1  took 15 seconds
\  bench2  took 16 seconds
\  bench3  took 17 seconds
\  bench4  took 17 seconds
\  bench5  took 19 seconds
\  sieve   took  4 seconds
\
\ HForth on Mac Quadra 800, 68040
\  bench1  took 1.73 seconds
\  bench2  took 6.48 seconds
\  bench3  took 2.65 seconds
\  bench4  took 2.50 seconds
\  bench5  took 1.91 seconds
\  sieve   took 0.45 seconds
\
\ pForthV9 on Mac Quadra 800
\  bench1  took 40 seconds
\  bench2  took 43 seconds
\  bench3  took 43 seconds
\  bench4  took 44 seconds
\  bench5  took 42 seconds
\  sieve   took 20 seconds
\
\ pForthV9 on PB5300, 100 MHz PPC 603 based Mac Powerbook
\  bench1  took 8.6 seconds	100 350 */	2.5
\  bench2  took 9.0 seconds			2.6
\  bench3  took 9.7 seconds			2.8
\  bench4  took 8.8 seconds			2.5
\  bench5  took 10.3 seconds			2.9
\  sieve   took 2.3 seconds			0.7
\
\ HForth on PB5300
\  bench1  took 1.1 seconds	k6/2 l4	0.4	0.4
\  bench2  took 3.6 seconds			0.6
\  bench3  took 1.7 seconds			0.7
\  bench4  took 1.2 seconds			0.6
\  bench5  took 1.3 seconds			0.6
\  sieve   took 0.2 seconds			0.1

( ------------------------------------------------------------------------------------------------ \
lib4th test w/ i586-pc-linux 2.2.19, k6/2 cpu:

Summary [s], XL586 354 mcs, l4-0.8.00 by f8 in <call-by-disp> mode:
all tests 3,585 s	\ best, worse was 5,6 s - quite uncertain results, in un-locked user mode!
        bench1  bench2  bench3  bench4  bench5  sieve sieve50
	0,372   0,617   0,682   0,649   0,724   0,089   0,442
\ ------------------------------------------------------------------------------------------------ )
\ lib4th v0.8.xx+ for pforth:

also ans

[DEFINED] dfrac. 0= [IF]
call-by-disp?
system f8ini also ans
also compiler if call-by-disp endif previous
[THEN]

[DEFINED] anew 0= [IF]	: anew marker ; [THEN]
[DEFINED] $ 0= [IF]
    : $ ans bl word count -dup 0= abort" empty stg"
      base@ >r hex number r> base! dpl@ 0< 
      if drop [_] literal else [_] dliteral endif ; immediate
[DEFINED] -> 0= [IF]	: -> [_] to ; immediate [THEN]
\ further change wrt locals defn, in <test.locals> and <match.strings>

[DEFINED] dfrac. 0= [IF]
\    [DEFINED] rational [IF]
\    also rational
\ : dfrac.rr
\   2>r 0 2r> df.j ;
\       previous
\     [ELSE]
\ for the timing display:
\ dfrac.rr	( dn1 n2 n3 -- )
\	display in a field of n2 chars the real fraction, n1 scaled by n2;
\	max no. of fractional digits from VALUE #prec, dft 10
\	fraction marker char-code from VALUE #dp, dft 44 ",".
\	e.g. { 10001 100 0 frac. } displays "100,01"
: dfrac.rr	( d1 n2 n3 n4 -- )
  drop
  #prec 1+ - 0max over abs dup 2>r >r m/mod r> .r abs #dp emit
  dup 0= r@ 0= and r@ or if					also fig
   #prec 0 do base@ um* j m/mod 0 .r dup 0= -leave loop		previous
  else base@ 1- digit #prec 0 do dup emit loop drop endif
  2rdrop drop ;
\     [THEN]
[THEN]
: dfrac.r -1 dfrac.rr ;
\ ------------------------------------------------------------------------------------------------ )
anew task-bench.fth
decimal

\ benchmark primitives
create #do 2000000   ,

: t1           #do @ 0      do                     loop ;
: t2  23 45    #do @ 0      do  swap               loop   2drop ;
: t3  23       #do @ 0      do  dup drop           loop drop ;
: t4  23 45    #do @ 0      do  over drop          loop 2drop ;
: t5           #do @ 0      do  23 45 + drop       loop ;
: t6  23       #do @ 0      do  >r r>              loop drop ;
: t7  23 45 67 #do @ 0      do  rot                loop 2drop drop ;
: t8           #do @ 0      do  23 2* drop         loop  ;
: t9           #do @ 10 / 0 do  23 5 /mod 2drop    loop ;
: t10     #do  #do @ 0      do  dup @ drop         loop drop ;

: foo ( noop ) ;
: t11          #do @ 0      do  foo                loop ;

\ more complex benchmarks -----------------------

\ BENCH1 - sum data ---------------------------------------
create data1 23 , 45 , 67 , 89 , 111 , 222 , 333 , 444 ,
: sum.cells ( addr num -- sum )
	0 swap \ sum
	0 DO
		over \ get address
		i cells + @ +
	LOOP
	swap drop
;

: bench1 ( -- )
	200000 0
	DO
		data1 8 sum.cells drop
	LOOP
;

\ BENCH2 - recursive factorial --------------------------
: factorial ( n -- n! )
	dup 1 >
	IF
		dup 1- recurse *
	ELSE
		drop 1
	THEN
;

: bench2 ( -- )
	200000 0
	DO
		10 factorial drop
	LOOP
;

\ BENCH3 - DEFER ----------------------------------
\ defer calc.answer
: answer ( n -- m )
	dup +
	$ a5a5 xor
	1000 max
;
defer calc.answer
' answer is calc.answer
: bench3
	1500000 0
	DO
		i calc.answer drop
	LOOP
;
	
\ BENCH4 - locals ---------------------------------
[DEFINED] { loctest and [IF]
: use.locals { x1 x2 | aa bb -- result }
	x1 2* -> aa
	x2 2/ -> bb
	x1 aa *
	x2 bb * +
;
[ELSE]
: use.locals
  0 0 locals| bb aa x2 x1 |
	x1 2* -> aa
	x2 2/ -> bb
	x1 aa *
	x2 bb * +
;
[THEN]
: bench4
	400000 0
	DO
		234 567 use.locals drop
	LOOP
;

\ BENCH5 - string compare -------------------------------
[DEFINED] { loctest and [IF]
: match.strings { $s1 $s2 | adr1 len1 adr2 len2 -- flag }
	$s1 count -> len1 -> adr1
	$s2 count -> len2 -> adr2
	len1 len2 -
	IF
		FALSE
	ELSE
		TRUE
		len1 0
		DO
			adr1 i + c@
			adr2 i + c@ -
			IF
				drop FALSE
				leave
			THEN
		LOOP
	THEN
;
[ELSE]
: match.strings
  0 0 0 0 locals| len2 adr2 len1 adr1 $s2 $s1 |
	$s1 count -> len1 -> adr1
	$s2 count -> len2 -> adr2
	len1 len2 -
	IF
		FALSE
	ELSE
		TRUE
		len1 0
		DO
			adr1 i + c@
			adr2 i + c@ -
			IF
				drop FALSE
				leave
			THEN
		LOOP
	THEN
;
[THEN]
: bench5 ( -- )
	60000 0
	DO
		" This is a string. X foo"
		" This is a string. Y foo" match.strings drop
	LOOP
;

\ SIEVE OF ERATOSTHENES from BYTE magazine -----------------------

DECIMAL 8190 CONSTANT TSIZE

VARIABLE FLAGS TSIZE ALLOT

: <SIEVE>  ( --- #primes )  FLAGS TSIZE 1 FILL
 0  TSIZE 0
 DO   ( n )  I FLAGS + C@
      IF    I  DUP +  3 +   DUP I +  (  I2*+3 I3*+3 )
           BEGIN  DUP TSIZE <  ( same flag )
           WHILE  0 OVER FLAGS + C! (  i' i'' )   OVER +
           REPEAT 2DROP  1+
      THEN
 LOOP       ;

: SIEVE  ." 10 iterations " CR  0   10 0 
  DO     <SIEVE> swap drop 
  LOOP   . ." primes " CR ;

: SIEVE50  ." 50 iterations " CR  0   50 0 
  DO     <SIEVE> swap drop 
  LOOP   . ." primes " CR ;

\ 10 iterations
\ 21.5 sec  Amiga Multi-Forth  Indirect Threaded
\ 8.82 sec  Amiga 1000 running JForth
\ ~5 sec  SGI Indy running pForthV9
decimal
cr cr ." pforth benchmarks" cr cr
ti-cal 1000 /mod swap 500 > - =: #ti 
1 to #prec
depth ndrop

\ \\also linux uid@ 0= if 3 sp@ sys iopl 3drop previous endif

tick
emms tick bench1  tick 2swap d- 2dup #ti 16 dfrac.r ."  ms - sum data" cr
emms tick bench2  tick 2swap d- 2dup #ti 16 dfrac.r ."  ms - recursive factorial" cr
emms tick bench3  tick 2swap d- 2dup #ti 16 dfrac.r ."  ms - DEFER" cr
emms tick bench4  tick 2swap d- 2dup #ti 16 dfrac.r ."  ms - locals" cr
emms tick bench5  tick 2swap d- 2dup #ti 16 dfrac.r ."  ms - string compare" cr
emms tick sieve   tick 2swap d- 2dup #ti 16 dfrac.r ."  ms" cr
emms tick sieve50 tick 2swap d- 2dup #ti 16 dfrac.r ."  ms" cr
tick depth 2/ 1- 2roll d-

\  \\also linux uid@ 0= if 0 sp@ sys iopl 3drop previous endif

3 to #prec

cr ."	Summary [s], " also fig .cpu previous space ti-cal 1000 dup * / . ." mcs, " version
."  by " 0 argstg type 
."  in <call-by-" call-by-disp? if ." disp" else ." uot" endif ." > mode:"
cr
."	all tests" ti-cal 6 dfrac.r ."  s"
cr

."		bench1	bench2	bench3	bench4	bench5	sieve	sieve50" 
cr
tab 7 0 do 6 i - 2pick ti-cal 2 5 dfrac.rr loop 
cr

depth ndrop

: k? 2 wait ?terminal 0= if bye endif ;
kbd' k? forget k?
