/
benchmark.f
1457 lines (1125 loc) · 41.4 KB
/
benchmark.f
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
\ Forth Inc. benchmark tests adapted by Tom Zimmer, MPE, et. al.
\ Other tests added by MPE.
\ 20030115 Added SPF4
\ 19991201 SFP004 Added iForth 1.11 (7 Nov 99) harness
\ 19991006 SFP003 Added Marcel Hendrix' DHRYSTONE test.
\ Factored out the system interface tests
\ Added results section
\ 19990928 SFP002 Added KEY? test to measure system I/O performance
\ 19990927 SFP001 Removed KEY? DROP from LZ77. This reduces the
\ API overhead which is tested elsewhere.
\ Added BigForth harness courtesy of Bernd Paysan
: start
S" FORTH-SYS" ENVIRONMENT? IF
S" SP-FORTH" COMPARE 0= IF
S" lib\include\tools.f" INCLUDED
THEN
THEN
;
start
0 [IF]
Introduction
============
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.
Some compilers include 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.
The word [O/N] is to stop some optimising compilers from
throwing away the multiply and divide operations.
The implementation of [O/N] should lay a NOP opcode on
optimising systems, and may be an immediate NOOP on others
Results for optimising compilers
================================
***********************************************
Athlon 700MHz under Windows XP with 128Mb RAM
***********************************************
MPE VFX Forth for Windows IA32 3.40.0849 5 April 2002
SPF4 build 10 19 February 2003
SwiftForth 2.2.2.9 07May2001
Primitives using no extensions
Test time (ms) including overhead VFX3.4 SPF4 SF
DO LOOP 40 40 40
+ 30 40 40
M+ 60 60 100
* 40 50 80
/ 350 331 391
M* 70 50 80
M/ 351 430 370
/MOD 380 351 371
*/ 461 471 461
ARRAY fill 10 20 40
==============================================================
Total: 1802 1843 1973
Win32 API: SendMessage 90 150 130
Win32 API: GetTickCount 70 170 160
System I/O: KEY? 40 791 1622
==============================================================
Total: 240 1131 1912
Eratosthenes sieve 1899 Primes 460 321 561
Fibonacci recursion ( 35 -> 9227465 ) 361 310 681
Hoare's quick sort (reverse order) 350 431 1032
Generate random numbers (1024 kb array) 341 290 480
LZ77 Comp. (400 kb Random Data Mem>Mem) 410 421 1973
Dhrystone (integer) 351 501 1112
==============================================================
Total: 2333 2314 5849
[THEN]
DECIMAL
\ ************************************************
\ Select system to be tested, set FORTHSYSTEM
\ to value of selected target.
\ Set SPECIFICS false to avoid system dependencies
\ Set SPECIFICS true to show off implementation tricks
\ ************************************************
1 CONSTANT VfxForth \ MPE ProForth VFX 3.4
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 11 July 1999
7 CONSTANT BigForth-Linux \ BigForth 11 July 1999
8 CONSTANT iForth \ iForth 1.12 5 Aug 2001
9 CONSTANT SPF4 \ SPF4
\ select system to test
S" FORTH-SYS" ENVIRONMENT? [IF]
S" SP-FORTH" COMPARE 0= [IF] SPF4 [ELSE] BYE [THEN]
[ELSE]
[DEFINED] SWIFT-BAR [IF] SwiftForth20 [ELSE] VfxForth [THEN]
[THEN] CONSTANT ForthSystem
FALSE CONSTANT specifics \ true to use system dependent code
TRUE CONSTANT ANSSystem \ Some Forth 83 systems cannot compile
\ all the test examples without carnal
\ knowledge, especially if the cmpiler
\ checks control structures.
: .specifics \ -- ; display trick state
." using" specifics 0=
IF ." no" THEN
." extensions"
;
: ALIGN-CACHE HERE 4096 2DUP MOD DUP IF - + ELSE 2DROP THEN HERE - ALLOT ;
\ ********************
\ ProForth VFX harness
\ ********************
VfxForth ForthSystem = [IF]
\ specifics 0= [if] -short-branches [then] \ remove this line for v3.0
specifics [if] absurd inlining [then]
extern: DWORD PASCAL GetTickCount( void )
: COUNTER \ -- ms
GetTickCount ;
[undefined] >pos [if]
: >pos \ n -- ; step to position n
out @ - spaces
;
[then]
: [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
;
: chars \ n -- n'
; immediate
0 constant ANSSystem
[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]
cd
cd \MyApps\BigForth
include ans.str
cd
cd \Products\VfSfp
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
;
: M/ \ d n1 -- quot
fm/mod nip
;
: 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
0 User32 SendMessage SendMessageA ( l w m h -- res )
0 kernel32 GetTickCount GetTickCount ( -- ticks )
previous
: SendMessage \ h m w l -- res
swap 2swap swap \ BigForth uses reverse order
SendMessage
;
0 constant HWND_DESKTOP
16 constant WM_CLOSE
[then]
[THEN]
\ ***************
\ iForth harness
\ ***************
iForth ForthSystem = [IF]
1 CELLS constant CELL
0 constant HWND_DESKTOP
1 constant WM_CLOSE
: NOT ( u1 -- u2 )
EVAL" 0= " ; IMMEDIATE
: COUNTER \ -- ms
EVAL" ?MS " ; IMMEDIATE
: >pos \ n -- ; step to position n
?AT NIP AT-XY ;
0 [if]
: M/ \ d n1 -- quot
EVAL" SM/REM NIP " ; IMMEDIATE
[then]
: buffer: \ n -- ; -- addr
create here over allot swap erase IMMEDIATE
does> ALITERAL ;
: [o/n] \ -- ; stop optimiser treating * DROP etc as no code
; immediate
: SendMessage \ h m w l -- res
EVAL" 3DROP " ; IMMEDIATE
: u2/ \ u -- u'
EVAL" 1 RSHIFT" ; IMMEDIATE
0 [if]
: 3drop \ x1 x2 x3 --
EVAL" DROP DROP DROP" ; IMMEDIATE
[then]
[THEN]
\ ***************
\ SPForth harness
\ ***************
SPF4 ForthSystem = [IF]
REQUIRE .R lib\include\core-ext.f
REQUIRE LOCALS| ~af\lib\locals-ans.f
REQUIRE CASE lib\ext\case.f
REQUIRE CASE-INS lib\ext\caseins.f
CASE-INS ON
REQUIRE getxy ~af\lib\getxy.f
WINAPI: SendMessageA user32.dll
WINAPI: GetTickCount kernel32.dll
0 CONSTANT HWND_DESKTOP
16 CONSTANT WM_CLOSE
: >pos \ n -- ; step to position n
getxy DROP - SPACES
;
: COUNTER \ -- ms
GetTickCount
;
: SendMessage \ h m w l -- res
SWAP 2SWAP SWAP \ SPF uses reverse order
SendMessageA
;
: [o/n] ; IMMEDIATE
: buffer: \ n -- ; -- addr
CREATE
HERE OVER ALLOT SWAP ERASE
;
: M/ ( d n1 -- quot ) FM/MOD NIP ;
: M+ ( d n -- d ) S>D D+ ;
: u2/ ( u -- u/2 ) 2/ ;
: NOT ( u1 -- u2 ) 0= ;
: <= > 0= ;
: >= < 0= ;
[THEN]
\ *************************************
\ Let's measure the generated code size
\ *************************************
here value start-here
\ ************************************
\ 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
70 constant extra-pos
: .HEADER \ -- ; display test header
cr ." Test time including overhead"
time-pos 3 + >pos ." ms"
iter-pos >pos ." times"
each-pos >pos ." ns (each)"
;
variable ms-elapsed
: TIMER ( ms iterations -- )
>r \ number of iterations
counter swap - \ elapsed time in ms
dup ms-elapsed ! \ save for later
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.
5000000 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
ALIGN-CACHE
: 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
\ *******************
35 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
10000 constant /array
/array 1+ array pointers
ALIGN-CACHE
: Precedes ( n n - f ) u< ;
: 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 ;
specifics VfxForth ForthSystem = AND [IF] -short-branches [THEN] \ remove this line for v3.0
: 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 ;
specifics VfxForth ForthSystem = AND [IF] +short-branches [THEN] \ remove this line for v3.0
: 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) 200 0 DO fillp 0 POINTERS 10000 SORT LOOP ;
: $SORT$
.ann ." Hoare's quick sort (reverse order) "
[$ (sort) 200 /array * $] ;
\ *******************************
\ End of Forth Inc benchmark code
\ *******************************
\ *********************************
\ "Random" Numbers
\ *********************************
1024 constant /random
variable ShiftRegister
1 ShiftRegister !
ALIGN-CACHE
: 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
[ HEX ] 40000000 [ DECIMAL ] \ ...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.
;
0 [IF]
\ More Forth-like versions of RANDBIT
: RandBit \ -- 0..1 ; Generates a "random" bit.
ShiftRegister @ DUP >R
1 and dup 0<> \ Tap at position 31.
R@ 8 and 0<> \ Tap at position 28.
xor \ If the XOR of the taps is non-zero...
if
R> 1 RSHIFT $40000000 OR
ShiftRegister !
else
R> 1 RSHIFT ShiftRegister !
then \ Store new shift register value.
;
: RandBit \ -- 0..1 ; Generates a "random" bit.
ShiftRegister @
dup dup 3 rshift xor 1 and \ XOR of bits 31 and 28, where bit 31=lsb
if
dup 1 RSHIFT $40000000 OR
ShiftRegister !
else
dup 1 RSHIFT ShiftRegister !
then \ Store new shift register value.
1 and \ return original bit 31
;
[THEN]
: 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
400 constant /lz77-size
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
( Input & Output Files )
0 VALUE infile 0 VALUE outfile
17 carray code-buf
VARIABLE len
VARIABLE last-match-length
VARIABLE code-buf-ptr
VARIABLE mask
ALIGN-CACHE
: 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. )
( 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 ) ( )
;
specifics VfxForth ForthSystem = and [IF] -short-branches [THEN] \ remove this line for v3.0
( 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 ! ( )
;
specifics VfxForth ForthSystem = and [IF] +short-branches [THEN] \ remove this line for v3.0
: 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 \ del SFP001
( 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 +!