version 1.110, 2002/08/20 07:59:01
|
version 1.116, 2002/09/22 14:21:30
|
Line 78 variable line-start \ pointer to start o
|
Line 78 variable line-start \ pointer to start o
|
0 line ! |
0 line ! |
2variable filename \ filename of original input file |
2variable filename \ filename of original input file |
0 0 filename 2! |
0 0 filename 2! |
|
2variable out-filename \ filename of the output file (for sync lines) |
|
0 0 out-filename 2! |
2variable f-comment |
2variable f-comment |
0 0 f-comment 2! |
0 0 f-comment 2! |
variable skipsynclines \ are sync lines ("#line ...") invisible to the parser? |
variable skipsynclines \ are sync lines ("#line ...") invisible to the parser? |
skipsynclines on |
skipsynclines on |
|
variable out-nls \ newlines in output (for output sync lines) |
|
0 out-nls ! |
|
variable store-optimization \ use store optimization? |
|
store-optimization off |
|
|
|
variable include-skipped-insts |
|
\ does the threaded code for a combined instruction include the cells |
|
\ for the component instructions (true) or only the cells for the |
|
\ inline arguments (false) |
|
include-skipped-insts off |
|
|
: th ( addr1 n -- addr2 ) |
: th ( addr1 n -- addr2 ) |
cells + ; |
cells + ; |
Line 121 skipsynclines on
|
Line 133 skipsynclines on
|
0 |
0 |
recover endtry |
recover endtry |
r> to outfile-id throw |
r> to outfile-id throw |
abort |
1 (bye) \ abort |
endif ; |
endif ; |
|
|
: quote ( -- ) |
: quote ( -- ) |
[char] " emit ; |
[char] " emit ; |
|
|
|
\ count output lines to generate sync lines for output |
|
|
|
: count-nls ( addr u -- ) |
|
bounds u+do |
|
i c@ nl-char = negate out-nls +! |
|
loop ; |
|
|
|
:noname ( addr u -- ) |
|
2dup count-nls |
|
defers type ; |
|
is type |
|
|
variable output \ xt ( -- ) of output word for simple primitives |
variable output \ xt ( -- ) of output word for simple primitives |
variable output-combined \ xt ( -- ) of output word for combined primitives |
variable output-combined \ xt ( -- ) of output word for combined primitives |
|
|
Line 231 variable in-part \ true if processing a
|
Line 255 variable in-part \ true if processing a
|
create combined-prims max-combined cells allot |
create combined-prims max-combined cells allot |
variable num-combined |
variable num-combined |
|
|
|
: map-combined { xt -- } |
|
\ perform xt for all components of the current combined instruction |
|
num-combined @ 0 +do |
|
combined-prims i th @ xt execute |
|
loop ; |
|
|
table constant combinations |
table constant combinations |
\ the keys are the sequences of pointers to primitives |
\ the keys are the sequences of pointers to primitives |
|
|
Line 364 defer inst-stream-f ( -- stack )
|
Line 394 defer inst-stream-f ( -- stack )
|
rdrop ; |
rdrop ; |
|
|
: store-single ( item -- ) |
: store-single ( item -- ) |
>r |
>r |
r@ same-as-in? |
store-optimization @ r@ same-as-in? and if |
if |
r@ item-in-index 0= r@ item-out-index 0= xor if |
r@ item-in-index 0= r@ item-out-index 0= xor |
." IF_" r@ item-stack @ stack-pointer 2@ type |
if |
." TOS(" r@ really-store-single ." );" cr |
." IF_" r@ item-stack @ stack-pointer 2@ type |
endif |
." TOS(" r@ really-store-single ." );" cr |
else |
endif |
r@ really-store-single cr |
else |
endif |
r@ really-store-single cr |
rdrop ; |
endif |
|
rdrop ; |
|
|
|
: store-double ( item -- ) |
: store-double ( item -- ) |
\ !! store optimization is not performed, because it is not yet needed |
\ !! store optimization is not performed, because it is not yet needed |
Line 647 stack inst-stream IP Cell
|
Line 675 stack inst-stream IP Cell
|
: type-c-code ( c-addr u xt -- ) |
: type-c-code ( c-addr u xt -- ) |
\ like TYPE, but replaces "INST_TAIL;" with tail code produced by xt |
\ like TYPE, but replaces "INST_TAIL;" with tail code produced by xt |
{ xt } |
{ xt } |
|
." {" cr |
|
." #line " c-line @ . quote c-filename 2@ type quote cr |
begin ( c-addr1 u1 ) |
begin ( c-addr1 u1 ) |
2dup s" INST_TAIL;" search |
2dup s" INST_TAIL;" search |
while ( c-addr1 u1 c-addr3 u3 ) |
while ( c-addr1 u1 c-addr3 u3 ) |
Line 655 stack inst-stream IP Cell
|
Line 685 stack inst-stream IP Cell
|
2r> 10 /string |
2r> 10 /string |
\ !! resync #line missing |
\ !! resync #line missing |
repeat |
repeat |
2drop type ; |
2drop type |
|
." #line " out-nls @ 2 + . quote out-filename 2@ type quote cr |
|
." }" cr ; |
|
|
: print-entry ( -- ) |
: print-entry ( -- ) |
." LABEL(" prim prim-c-name 2@ type ." )" ; |
." LABEL(" prim prim-c-name 2@ type ." )" ; |
|
|
: output-c ( -- ) |
: output-c ( -- ) |
print-entry ." /* " prim prim-name 2@ type ." ( " prim prim-stack-string 2@ type ." ) */" cr |
print-entry ." /* " prim prim-name 2@ type ." ( " prim prim-stack-string 2@ type ." ) */" cr |
." /* " prim prim-doc 2@ type ." */" cr |
." /* " prim prim-doc 2@ type ." */" cr |
." NAME(" quote prim prim-name 2@ type quote ." )" cr \ debugging |
." NAME(" quote prim prim-name 2@ type quote ." )" cr \ debugging |
." {" cr |
." {" cr |
." DEF_CA" cr |
." DEF_CA" cr |
print-declarations |
print-declarations |
." NEXT_P0;" cr |
." NEXT_P0;" cr |
flush-tos |
flush-tos |
fetches |
fetches |
print-debug-args |
print-debug-args |
stack-pointer-updates |
stack-pointer-updates |
." {" cr |
prim prim-c-code 2@ ['] output-c-tail type-c-code |
." #line " c-line @ . quote c-filename 2@ type quote cr |
output-c-tail2 |
prim prim-c-code 2@ ['] output-c-tail type-c-code |
." }" cr |
." }" cr |
cr |
output-c-tail2 |
|
." }" cr |
|
cr |
|
; |
; |
|
|
: disasm-arg { item -- } |
: disasm-arg { item -- } |
Line 715 stack inst-stream IP Cell
|
Line 744 stack inst-stream IP Cell
|
endif |
endif |
." }" cr ; |
." }" cr ; |
|
|
|
: output-profile-part ( p ) |
|
." add_inst(b, " quote |
|
prim-name 2@ type |
|
quote ." );" cr ; |
|
|
: output-profile-combined ( -- ) |
: output-profile-combined ( -- ) |
\ generate code for postprocessing the VM block profile stuff |
\ generate code for postprocessing the VM block profile stuff |
." if (VM_IS_INST(*ip, " function-number @ 0 .r ." )) {" cr |
." if (VM_IS_INST(*ip, " function-number @ 0 .r ." )) {" cr |
num-combined @ 0 +do |
['] output-profile-part map-combined |
." add_inst(b, " quote |
|
combined-prims i th @ prim-name 2@ type |
|
quote ." );" cr |
|
loop |
|
." ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr |
." ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr |
combined-prims num-combined @ 1- th @ prim-c-code 2@ s" SET_IP" search nip nip |
combined-prims num-combined @ 1- th @ prim-c-code 2@ s" SET_IP" search nip nip |
combined-prims num-combined @ 1- th @ prim-c-code 2@ s" SUPER_END" search nip nip or if |
combined-prims num-combined @ 1- th @ prim-c-code 2@ s" SUPER_END" search nip nip or if |
Line 808 stack inst-stream IP Cell
|
Line 838 stack inst-stream IP Cell
|
: output-alias ( -- ) |
: output-alias ( -- ) |
( primitive-number @ . ." alias " ) ." Primitive " prim prim-name 2@ type cr ; |
( primitive-number @ . ." alias " ) ." Primitive " prim prim-name 2@ type cr ; |
|
|
|
: output-prim-num ( -- ) |
|
prim prim-num @ 8 + 4 .r space prim prim-name 2@ type cr ; |
|
|
: output-forth ( -- ) |
: output-forth ( -- ) |
prim prim-forth-code @ 0= |
prim prim-forth-code @ 0= |
IF \ output-alias |
IF \ output-alias |
Line 819 stack inst-stream IP Cell
|
Line 852 stack inst-stream IP Cell
|
THEN ; |
THEN ; |
|
|
: output-tag-file ( -- ) |
: output-tag-file ( -- ) |
name-filename 2@ last-name-filename 2@ compare if |
name-filename 2@ last-name-filename 2@ str= 0= if |
name-filename 2@ last-name-filename 2! |
name-filename 2@ last-name-filename 2! |
#ff emit cr |
#ff emit cr |
name-filename 2@ type |
name-filename 2@ type |
Line 919 stack inst-stream IP Cell
|
Line 952 stack inst-stream IP Cell
|
prim to combined |
prim to combined |
0 num-combined ! |
0 num-combined ! |
current-depth max-stacks cells erase |
current-depth max-stacks cells erase |
|
include-skipped-insts @ current-depth 0 th ! |
max-depth max-stacks cells erase |
max-depth max-stacks cells erase |
min-depth max-stacks cells erase |
min-depth max-stacks cells erase |
prim prim-effect-in prim prim-effect-in-end ! |
prim prim-effect-in prim prim-effect-in-end ! |
Line 930 stack inst-stream IP Cell
|
Line 964 stack inst-stream IP Cell
|
: min! ( n addr -- ) |
: min! ( n addr -- ) |
tuck @ min swap ! ; |
tuck @ min swap ! ; |
|
|
|
: inst-stream-correction ( nin1 nstack -- nin2 ) |
|
0= if |
|
include-skipped-insts @ - |
|
endif ; |
|
|
: add-depths { p -- } |
: add-depths { p -- } |
\ combine stack effect of p with *-depths |
\ combine stack effect of p with *-depths |
max-stacks 0 ?do |
max-stacks 0 ?do |
current-depth i th @ |
current-depth i th @ |
p prim-stacks-in i th @ + |
p prim-stacks-in i th @ + i inst-stream-correction |
dup max-depth i th max! |
dup max-depth i th max! |
p prim-stacks-out i th @ - |
p prim-stacks-out i th @ - |
dup min-depth i th min! |
dup min-depth i th min! |
Line 1026 stack inst-stream IP Cell
|
Line 1065 stack inst-stream IP Cell
|
part-fetches |
part-fetches |
print-debug-args |
print-debug-args |
prim add-depths \ !! right place? |
prim add-depths \ !! right place? |
." {" cr |
|
." #line " c-line @ . quote c-filename 2@ type quote cr |
|
prim prim-c-code 2@ ['] output-combined-tail type-c-code |
prim prim-c-code 2@ ['] output-combined-tail type-c-code |
." }" cr |
|
part-output-c-tail |
part-output-c-tail |
." }" cr ; |
." }" cr ; |
|
|
: output-parts ( -- ) |
: output-parts ( -- ) |
prim >r in-part on |
prim >r in-part on |
current-depth max-stacks cells erase |
current-depth max-stacks cells erase |
num-combined @ 0 +do |
['] output-part map-combined |
combined-prims i th @ output-part |
|
loop |
|
in-part off |
in-part off |
r> to prim ; |
r> to prim ; |
|
|
Line 1064 stack inst-stream IP Cell
|
Line 1098 stack inst-stream IP Cell
|
|
|
\ peephole optimization rules |
\ peephole optimization rules |
|
|
|
\ data for a simple peephole optimizer that always tries to combine |
|
\ the currently compiled instruction with the last one. |
|
|
\ in order for this to work as intended, shorter combinations for each |
\ in order for this to work as intended, shorter combinations for each |
\ length must be present, and the longer combinations must follow |
\ length must be present, and the longer combinations must follow |
\ shorter ones (this restriction may go away in the future). |
\ shorter ones (this restriction may go away in the future). |
|
|
: output-peephole ( -- ) |
: output-peephole ( -- ) |
combined-prims num-combined @ 1- cells combinations search-wordlist |
combined-prims num-combined @ 1- cells combinations search-wordlist |
s" the prefix for this combination must be defined earlier" ?print-error |
s" the prefix for this superinstruction must be defined earlier" ?print-error |
." {" |
." {" |
execute prim-num @ 5 .r ." ," |
execute prim-num @ 5 .r ." ," |
combined-prims num-combined @ 1- th @ prim-num @ 5 .r ." ," |
combined-prims num-combined @ 1- th @ prim-num @ 5 .r ." ," |
Line 1078 stack inst-stream IP Cell
|
Line 1115 stack inst-stream IP Cell
|
combined prim-c-name 2@ type ." */" |
combined prim-c-name 2@ type ." */" |
cr ; |
cr ; |
|
|
: output-forth-peephole ( -- ) |
|
combined-prims num-combined @ 1- cells combinations search-wordlist |
|
s" the prefix for this combination must be defined earlier" ?print-error |
|
execute prim-num @ 5 .r |
|
combined-prims num-combined @ 1- th @ prim-num @ 5 .r |
|
combined prim-num @ 5 .r ." prim, \ " |
|
combined prim-c-name 2@ type |
|
cr ; |
|
|
|
|
\ cost and superinstruction data for a sophisticated combiner (e.g., |
|
\ shortest path) |
|
|
|
\ This is intended as initializer for a structure like this |
|
|
|
\ struct cost { |
|
\ int loads; /* number of stack loads */ |
|
\ int stores; /* number of stack stores */ |
|
\ int updates; /* number of stack pointer updates */ |
|
\ int length; /* number of components */ |
|
\ int *components; /* array of vm_prim indexes of components */ |
|
\ }; |
|
|
|
\ How do you know which primitive or combined instruction this |
|
\ structure refers to? By the order of cost structures, as in most |
|
\ other cases. |
|
|
|
: compute-costs { p -- nloads nstores nupdates } |
|
\ compute the number of loads, stores, and stack pointer updates |
|
\ of a primitive or combined instruction; does not take TOS |
|
\ caching into account, nor that IP updates are combined with |
|
\ other stuff |
|
0 max-stacks 0 +do |
|
p prim-stacks-in i th @ + |
|
loop |
|
0 max-stacks 0 +do |
|
p prim-stacks-out i th @ + |
|
loop |
|
0 max-stacks 0 +do |
|
p prim-stacks-in i th @ p prim-stacks-out i th @ <> - |
|
loop ; |
|
|
|
: output-num-part ( p -- ) |
|
prim-num @ 4 .r ." ," ; |
|
|
|
: output-costs ( -- ) |
|
." {" prim compute-costs |
|
rot 2 .r ." ," swap 2 .r ." ," 2 .r ." ," |
|
combined if |
|
num-combined @ 2 .r |
|
." , ((int []){" ['] output-num-part map-combined ." })}, /* " |
|
else |
|
." 1, ((int []){" prim prim-num @ 4 .r ." })}, /* " |
|
endif |
|
prim prim-name 2@ type ." */" |
|
cr ; |
|
|
\ the parser |
\ the parser |
|
|
Line 1116 print-token !
|
Line 1191 print-token !
|
\ when input points to a newline, check if the next line is a |
\ when input points to a newline, check if the next line is a |
\ sync line. If it is, perform the appropriate actions. |
\ sync line. If it is, perform the appropriate actions. |
rawinput @ >r |
rawinput @ >r |
s" #line " r@ over compare 0<> if |
s" #line " r@ over str= 0= if |
rdrop 1 line +! EXIT |
rdrop 1 line +! EXIT |
endif |
endif |
0. r> 6 chars + 20 >number drop >r drop line ! r> ( c-addr ) |
0. r> 6 chars + 20 >number drop >r drop line ! r> ( c-addr ) |