benchmark.fs

\ 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 th use 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
\ ************************************************

7 constant ForthSystem
false constant specifics        \ true to use system dependent code

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 4.2
6  constant BigForth            \ BigForth 26sep1999
7  constant BigForth-Linux      \ BigForth 26sep1999

: .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]


\ ******************
\ BigForth harness
\ ******************

BigForth ForthSystem =
BigForth-Linux ForthSystem =  or
[if]

include ans.fs

Code u2/        \ n -- n/2
  1 # AX shr
  Next
end-code  macro

: COUNTER       \ -- ms
  timer@ >us &1000 um/mod nip ;

: >pos          \ n -- ; step to position n
  at? swap drop - spaces
;

: buffer:       \ n -- ; -- addr
  create
    here  over allot  swap erase
;

: [o/n]         \ -- ; stop optimiser treating * DROP etc as no code
; immediate

BigForth ForthSystem = [if]
also DOS
1 legacy !
4 User32 SendMessage SendMessageA       ( l w m h -- res )
0 kernel32 GetTickCount GetTickCount    ( -- ticks )
legacy on
previous

0 constant HWND_DESKTOP
16 constant WM_CLOSE
[else]
: GetTickCount  timer@ >us &1000 um/mod nip ;
: SendMessage  2drop 2drop 0 ;

0 constant HWND_DESKTOP
16 constant WM_CLOSE
[then]
[then]


\ ************************************
\ FORTH, Inc.  32 Bit Benchmark Source
\ ************************************

CELL NEGATE CONSTANT -CELL

CR .( Loading benchmark routines)


\ ***********************
\ Benchmark support words
\ ***********************

\ column positions
40 constant time-pos
50 constant iter-pos
60 constant each-pos

: .HEADER       \ -- ; display test header
  cr ." Test time including overhead"
  time-pos 3 + >pos  ." ms"
  iter-pos >pos ." times"
  each-pos >pos  ." ns (each)"
;

: TIMER ( ms iterations -- )
  >r                                    \ number of iterations
  counter swap -                        \ elapsed time in ms
  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
;

: .ann          \ -- ; banner announcment
  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 ;

\ CARRAY  creates a byte size array.
: CARRAY ( n)   CREATE  ALLOT
                DOES> ( n - a)  + ;

\ ARRAY  creates a word size array.
: ARRAY ( n)    CREATE  CELLS ALLOT
                DOES> ( n - a) SWAP CELLS + ;


\ ****************************
\ Basic FORTH, Inc. Benchmarks
\ ****************************
\ This series of tests analyses the Forth primitives.

1000000 constant /prims
\ -- #iterations; all of these words return the number of iterations
: $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  $] ;

\ $*/$  tests the math primitive  */ .  This may or may not tell
\    you how the other math primitives perform depending on
\    how  */  has been coded.
: $*/$    .ann ." */"       [$  /prims DUP 1+ 1 DO  I I I */ [o/n] DROP  LOOP  $] ;


\ ****************************************
\ Eratosthenes sieve benchmark program
\ This is NOT the original BYTE benchmark.
\ ****************************************

8190 CONSTANT SIZE
SIZE buffer: FLAGS

: DO-PRIME
      1000 0 DO
               FLAGS SIZE -1 FILL
               0 SIZE 0
               DO I FLAGS + C@
                    IF I 2* 3 + DUP I +
                         BEGIN DUP SIZE <
                         WHILE DUP FLAGS + 0 SWAP C! OVER +
                         REPEAT 2DROP
                              1+
                    THEN
               LOOP
               DROP
         LOOP
           ;

: $SIEVE$   .ann ." Eratosthenes sieve "  [$  DO-PRIME  SIZE 1000 *  ." 1899 Primes"  $] ;


\ *******************
\ Fibonacci recursion
\ *******************

34 constant /fib

: FIB ( n -- n' )
   DUP 1 > IF
      DUP 1- RECURSE  SWAP 2-  RECURSE  +
   THEN ;

: $FIB$
   .ann ." Fibonacci recursion ( "
   [$  /fib dup . ." -> " FIB dup . ." )" /fib - $] ;


\ *********************************
\ QuickSort from Hoare & Wil Baden
\ also contains the array fill test
\ *********************************

7 CELLS CONSTANT THRESHOLD

specifics [if]

PfwVfx ForthSystem = [if]
%macro Precedes ( n1 n2 -- f )
  u<
%endmacro
%macro Exchange ( a1 a2 -- )
  2dup @ swap @ rot ! swap !
%endmacro
[then]

Pfw22 ForthSystem = [if]
: Precedes  ( n n - f )    u< ;
: Exchange  ( a1 a2 -- )   2DUP  @ SWAP @ ROT !  SWAP ! ;
[then]

SwiftForth15 ForthSystem = [if]
: Precedes  ( n n - f )    u< ;
: Exchange  ( a1 a2 -- )   2DUP  @ SWAP @ ROT !  SWAP ! ;
[then]

SwiftForth20 ForthSystem = [if]
: Precedes  ( n n - f )    u< ;
: Exchange  ( a1 a2 -- )   2DUP  @ SWAP @ ROT !  SWAP ! ;
[then]

Win32Forth ForthSystem = [if]
: Precedes  ( n n - f )    u< ;
: Exchange  ( a1 a2 -- )   2DUP  @ SWAP @ ROT !  SWAP ! ;
[then]

BigForth ForthSystem =
BigForth-Linux ForthSystem = or [if]
: Precedes  ( n n - f )    u< ; macro
: Exchange  ( a1 a2 -- )   2DUP  @ SWAP @ ROT !  SWAP ! ; macro
[then]

[else]
: Precedes  ( n n - f )    u< ;
: Exchange  ( a1 a2 -- )   2DUP  @ SWAP @ ROT !  SWAP ! ;
[then]

: 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 0 DO  fillp  LOOP  100 /array * $]  ;

: (sort)  100 0 DO   fillp  0 POINTERS 10000 SORT   LOOP ;

: $SORT$
  .ann ." Hoare's quick sort (reverse order)  "
  [$  (sort) 100 /array *  $] ;


\ *********************************
\ "Random" Numbers
\ *********************************

1024 constant /random

variable ShiftRegister
       1 ShiftRegister !

: RandBit       \ -- 0..1 ; Generates a "random" bit.
  ShiftRegister @ $00000001 and         \ Gen result bit for this time thru.
  dup 0<>                               \ Tap at position 31.
  ShiftRegister @ $00000008 and 0<>     \ Tap at position 28.
  xor 0<>                               \ If the XOR of the taps is non-zero...
  if
    $40000000                           \ ...shift in a "one" bit else...
  else
    $00000000                           \ ...shift in a "zero" bit.
  then
  ShiftRegister @ u2/                   \ Shift register one bit right.
  or                                    \ OR in new left-hand bit.
  ShiftRegister !                       \ Store new shift register value.
;

: RandBits      \ n -- 0..2^(n-1) ; Generate an n-bit "random" number.
  0                                     \ Result's start value.
  swap 0
  do
    2* RandBit or                       \ Generate next "random" bit.
  loop
;

: (randtest)    \ --
  1 ShiftRegister !
  /random 256 cells * allocate
  if
    cr ." Failed to allocate " /random . ." kb for test"
    abort
  then
  /random 256 * 0 do 32 RandBits over i cells + ! loop
  free drop
;

: $RAND$
  .ann ." Generate random numbers (" /random . ." kb array)"
  [$  (randtest)  /random 256 * $] ;


\ *********************************
\ LZ77 compression
\ *********************************

0       Value   lz77-buffer
0       Value   lz77-Pos
0       Value   lz77-BytesLeft

100 constant /lz77-size

: init-test-buffer
  /lz77-size 256 cells * 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-size 256 * 0
  do  32 randbits lz77-buffer i cells + !  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 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 then
;

(     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    Threshold ( 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    codesize    ( Code Size Counter )
\ VARIABLE  printcount  ( Counter for Reporting Progress )

( 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

specifics  PfwVfx ForthSystem = and [if]
  0 lson constant .lson   %cmacro lson  cells .lson +  %endmacro
  0 rson constant .rson   %cmacro rson  cells .rson +  %endmacro
  0 dad  constant .dad    %cmacro dad   cells .dad  +  %endmacro
[then]

( 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< not IF                           ( r p)

                  DUP rson @ Nil = not IF
                        rson @
                  ELSE

                        2DUP rson !
                        SWAP dad !              ( )
                        EXIT

                  THEN
            ELSE                                ( r p)

                  DUP lson @ Nil = not 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 < not

            ELSE
                  DROP FALSE
            THEN                                ( r p cmp flag)
      UNTIL                                     ( r p cmp)
      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= IF    EXIT    THEN                     ( 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)
\            key? drop
            ( match_length may be spuriously long at end of text. )
            match-length @ len @ > IF    len @ match-length !   THEN

            match-length @ Threshold > not 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 > Threshold. )

                  match-position @  code-buf-ptr @ code-buf C!
                  1 code-buf-ptr +!

                  match-position @  8 RSHIFT  4 LSHIFT ( . . j)
                        match-length @  Threshold -  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 3 1 + 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 3 1 + 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
            \     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> not
      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)"
  [$  code77  1 $] ;


\ *********************************
\ API Call OverHead
\ *********************************

HWND_DESKTOP VALUE hWnd

40000 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 $]
;

1000000 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
   [$  
     $DO$
     $+$  $M+$
     $*$  $/$  $M*$  $M/$  $/MOD$  $*/$
     $FILL$  $API1$  $API2$
   CR  ." Total:"  1 $]
   CR
   .ann ." This system's application performance" .specifics CR
   .header
   [$  
     $SIEVE$  $FIB$  $SORT$  $RAND$  $CODE77$
   CR  ." Total:"  1 $]
;

BENCHMARK

CR CR .( To run the benchmark program again, type BENCHMARK )