Вот механизм предкомпиляции в действии:
Код:
\ Таблица предкомпияции
\ 20.05.2017 ~er
\
\ Избавился от хеширования
\ подключил структуры
\ изменил разрядность некоторых элементов структуры
REQUIRE STRUCT: ~ER\STRUCT-SUGAR.F
STRUCT: rec-event
CELL -- gr-e
CELL -- gr-h
CELL -- group-name
30 CELLS -- sp-ev
30 CELLS -- sp-h
STRUCT;
0 VALUE EVENT-TABLE
\ добавить запись-пустышку в таблицу и
\ выдать адрес записи
: new-event-rec \ xt-e - rec-addr
EVENT-TABLE >R
BEGIN
R@ gr-e @ 0=
R@ gr-e @ -1 =
OR
INVERT
WHILE
R> rec-event + >R
REPEAT
\ очистка на случай, если запись удалена
R@ rec-event 0 FILL
1 R@ gr-e !
R@ sp-ev !
R>
;
\ если xt имееся в записях или группах записей,
\ то выдать адрес записи и вернуть истину
\ в противном случае xt и ложь
: event-rec? \ xt -- addr-rec -1| xt 0
EVENT-TABLE >R
BEGIN
R@ gr-e @ 0= IF RDROP 0 EXIT THEN
R@ gr-e @ -1 <> IF
DUP
R@ sp-ev R@ gr-e @ CELLS
ROT >R
RP@ CELL
SEARCH NIP NIP
RDROP
INVERT \ 0 ЕСЛИ ИСТИНА
ELSE
-1
THEN
WHILE
R> rec-event + >R
REPEAT
DROP
R> -1
;
\ пометить запись для удаления в будущем
: mark-delete-ev \ addr-rec --
rec-event -1 FILL
;
\ создать псевдоним для группы из строки
\ псевдоним имеет длину равную CELL
: event-group-psevd \ addr u -- n
DUP CELL <
IF
0 >R
RP@ SWAP MOVE
R>
ELSE
DROP @
THEN
;
\ собрать группу из ранее записанных
\ в таблицу слов предкомпиляции,
\ которые имеют адреса xt1 ... xtn количеством n
\ Группа сотворяется с псевдонимом addr u
\ Если среди xt есть те, которые отсутствуют в таблице,
\ то ловим исключение
\ Если запиcи пусты т.е. имеют только xt,
\ то запись помечается для удаления
\ создаётся запись-группа и возвращаеся её адрес
\
: compute-group \ xt1 xt2 .. xtn n addr u -- addr-rec
event-group-psevd >R
DUP >R
BEGIN
R@ PICK R@ - DUP \ если очередное взятие не равно n
WHILE
R@ +
\ DUP . \ отладка
event-rec?
0= IF . CR -3001 THROW THEN
REPEAT
DROP
R@
BEGIN
SWAP
>R
R@ gr-h @ \ если есть обработчик
R@ gr-e @ 1 > \ или это группа
OR
0=
IF R@ mark-delete-ev THEN
RDROP
1-
DUP 0=
UNTIL
DROP
DROP
0 new-event-rec >R
RP@ CELL+ @ R@ gr-e !
\ переносим данные со стека в таблицу. Стек растёт вниз!!!
SP@
R@ sp-ev
RP@ CELL+ @ CELLS
MOVE
\ очищаем стек от слов
SP@ RP@ CELL+ @ CELLS + SP!
R>
RDROP
DUP group-name R> SWAP !
;
\ добавить обработчик xt-h к слову предкомпиляции xt-e
\ если xt-e не слово предкомпиляции, то ловим исключение
\ если xt-e не в записи, а в группе записей,
\ то создать запись xt-e с обработчиком
: ->EVENT \ xt-h xt-e --
>R
R@ event-rec?
0= IF . CR -3001 THROW THEN
\ если слово предкомпиляции в группе
DUP gr-e @ 1 > IF
EVENT-TABLE >R
rec-event +
TO EVENT-TABLE
RP@ CELL+ @ \ D: -- xt-e
\ если слово только в группе или группах,
\ то создаём запись
event-rec? 0=
IF
R> TO EVENT-TABLE
new-event-rec
ELSE
DROP \ rec-addr --
\ продолжаем искать запись
\
\ ." RECURSER" CR \ отладка
\ DEPTH .SN CR \ отладка
RP@ CELL+ @ \ D: -- xt-e
RECURSE
R> TO EVENT-TABLE
RDROP EXIT
THEN
THEN
\ DEPTH .SN CR \ отладка
>R \ R: -- rec-addr
R@ gr-h @ CELLS \ СМЕЩЕНИЕ
R@ sp-h \ ДЛЯ ПОКЛАДА ОБРАБОТЧИКА
+
!
\ DEPTH .SN CR \ отдадка
\ увеличить кол-во обработчиков на 1
R@ gr-h 1+!
RDROP
RDROP
;
: find-next-rec \ xt-e rec-addr1 -- xt-e rec-addr? -1 | xt-e 0
2>R
BEGIN
BEGIN
R@ gr-e @ 0=
R@ gr-e @ -1 =
OR INVERT
WHILE
R@ sp-ev R@ gr-e @ CELLS
RP@ CELL+ CELL
SEARCH NIP NIP
IF 2R> -1 EXIT THEN
R> rec-event + >R
REPEAT
\ Внимание!!! манипуляция со стеком потока-управления
R@ gr-e @ -1 = IF
R> rec-event + >R
[ 2SWAP ] AGAIN
THEN
RDROP
R> 0
;
\ добавиь обработчик в группу слов предкомпиляции,
\ которая идентифицируется псевдонимом
\ если псевдоним не найден в записях
\ то получаем исключение
: ->EVENT-GROUP \ xt-h addr u --
event-group-psevd
EVENT-TABLE >R
BEGIN
R@ gr-e @
WHILE
R@ @ -1 <> IF
R@ group-name @ OVER =
R@ gr-e @ 1 >
AND
IF
DROP
R@ sp-h
R@ gr-h @ CELLS
+ !
R@ gr-h 1+!
RDROP
EXIT
THEN
THEN
R> rec-event + >R
REPEAT
-3003 THROW
;
USER-VALUE EVENT-RP@
\ выйти из обработчика и EVENT-COMPILE,
: EVENT-EXIT EVENT-RP@ RP! ;
: EVENT-COMPILE, \ FFA@1 xt1 -- FFA@? xt1|xt?|'noop
RP@ TO EVENT-RP@
>R
R@ event-rec?
0= IF -3005 THROW THEN
DROP
R@ EVENT-TABLE
BEGIN
find-next-rec
WHILE
>R \ rec-addr
R@ sp-h R@ gr-h @
0 ?DO
I CELLS + >R
\ xt-h:
\ FFA@ xt -- ??? FFA@ xt
R@ @ EXECUTE
R>
LOOP
2DROP \ ... xt sp-h -- ...
R> rec-event + R@ SWAP
REPEAT
RDROP
;
Код для тестов
Цитата:
REQUIRE SEE lib\ext\disasm.f
~ER\EVENT-TABLE2.F
\ выделяем память под таблицу
100000 ALLOCATE THROW
DUP 100000 0 FILL
TO EVENT-TABLE
' + new-event-rec DROP
' - new-event-rec DROP
' / new-event-rec DROP
' * new-event-rec DROP
' MOD new-event-rec DROP
' XOR new-event-rec DROP
' OR new-event-rec DROP
' AND new-event-rec DROP
' + ' -
' / ' *
' MOD
' XOR ' OR ' AND
8 S" AL_O" compute-group DROP
: handlerOPT_2op \ FFA@ xt -- FFA@ xt| FFA@1 'noop
HERE 5 - \ skip MOV EAX ???
6 - 6
['] DUP 6 COMPARE 0=
HERE 5 -
6 -
5 - \ skip MOV EAX ???
6 - 6
['] DUP 6 COMPARE 0=
AND
HERE 5 - C@ 0xB8 = \ eax mov-code
HERE 5 -
6 - 5 - C@ 0xB8 = \ eax mov-code
AND
AND IF >R
HERE 4 - @
HERE 5 - 6 - 4 - @
SWAP R@ EXECUTE
HERE 5 - 6 - DP !
HERE 4 - !
DROP
1 \ immediate-flag
['] NOOP
\ стек возвратов не освобождаем
\ за нас это делает слово ниже
EVENT-EXIT
THEN
;
' handlerOPT_2op S" AL_O" ->EVENT-GROUP
\ аналог СПФ-ского LIT, только без оптимизации на ходу
: LT, \ zn --
['] DUP 6 S,
0xB8 C, ,
;
HEADER TEST
10 LT, 20 LT, 6 ' * EVENT-COMPILE,
RET,
SEE TEST
Ну, и итог оптимизации:
Цитата:
~ER\EVENT-TEST.F
575E7B 8D6DFC LEA EBP , FC [EBP]
575E7E 894500 MOV 0 [EBP] , EAX
575E81 B8C8000000 MOV EAX , # C8
575E86 C3 RET NEAR