version 1.102, 2001/12/24 14:09:06
|
version 1.107, 2002/08/07 10:11:18
|
Line 312 defer inst-stream-f ( -- stack )
|
Line 312 defer inst-stream-f ( -- stack )
|
item-stack @ stack-type @ type-c-name 2@ ; |
item-stack @ stack-type @ type-c-name 2@ ; |
|
|
: fetch-single ( item -- ) |
: fetch-single ( item -- ) |
\ fetch a single stack item from its stack |
\ fetch a single stack item from its stack |
>r |
>r |
r@ item-name 2@ type |
." vm_" r@ item-stack-type-name type |
." = vm_" r@ item-stack-type-name type |
." 2" r@ item-type @ print-type-prefix ." (" |
." 2" r@ item-type @ print-type-prefix ." (" |
r@ item-in-index r@ item-stack @ stack-access ." ," |
r@ item-in-index r@ item-stack @ stack-access |
r@ item-name 2@ type |
." );" cr |
." );" cr |
rdrop ; |
rdrop ; |
|
|
: fetch-double ( item -- ) |
: fetch-double ( item -- ) |
\ fetch a double stack item from its stack |
\ fetch a double stack item from its stack |
>r |
>r |
." vm_two" |
." vm_two" |
r@ item-stack-type-name type ." 2" |
r@ item-stack-type-name type ." 2" |
r@ item-type @ print-type-prefix ." (" |
r@ item-type @ print-type-prefix ." (" |
r@ item-name 2@ type ." , " |
r@ item-in-index r@ item-stack @ 2dup ." (Cell)" stack-access |
r@ item-in-index r@ item-stack @ 2dup ." (Cell)" stack-access |
." , " -1 under+ ." (Cell)" stack-access |
." , " -1 under+ ." (Cell)" stack-access |
." , " r@ item-name 2@ type |
." );" cr |
." )" cr |
rdrop ; |
rdrop ; |
|
|
: same-as-in? ( item -- f ) |
: same-as-in? ( item -- f ) |
\ f is true iff the offset and stack of item is the same as on input |
\ f is true iff the offset and stack of item is the same as on input |
Line 355 defer inst-stream-f ( -- stack )
|
Line 355 defer inst-stream-f ( -- stack )
|
>r r@ item-stack @ stack-out @ r> item-offset @ - 1- ; |
>r r@ item-stack @ stack-out @ r> item-offset @ - 1- ; |
|
|
: really-store-single ( item -- ) |
: really-store-single ( item -- ) |
>r |
>r |
r@ item-out-index r@ item-stack @ stack-access ." = vm_" |
." vm_" |
r@ item-type @ print-type-prefix ." 2" |
r@ item-type @ print-type-prefix ." 2" |
r@ item-stack-type-name type ." (" |
r@ item-stack-type-name type ." (" |
r@ item-name 2@ type ." );" |
r@ item-name 2@ type ." ," |
rdrop ; |
r@ item-out-index r@ item-stack @ stack-access ." );" |
|
rdrop ; |
|
|
: store-single ( item -- ) |
: store-single ( item -- ) |
>r |
>r |
Line 385 defer inst-stream-f ( -- stack )
|
Line 386 defer inst-stream-f ( -- stack )
|
r@ item-name 2@ type ." , " |
r@ item-name 2@ type ." , " |
r@ item-out-index r@ item-stack @ 2dup stack-access |
r@ item-out-index r@ item-stack @ 2dup stack-access |
." , " -1 under+ stack-access |
." , " -1 under+ stack-access |
." );" cr |
." )" cr |
rdrop ; |
rdrop ; |
|
|
: single ( -- xt1 xt2 n ) |
: single ( -- xt1 xt2 n ) |
Line 423 wordlist constant prefixes
|
Line 424 wordlist constant prefixes
|
stack r@ type-stack ! |
stack r@ type-stack ! |
rdrop ; |
rdrop ; |
|
|
: type-prefix ( xt1 xt2 n stack "prefix" -- ) |
: type-prefix ( addr u xt1 xt2 n stack "prefix" -- ) |
get-current >r prefixes set-current |
get-current >r prefixes set-current |
create-type r> set-current |
create-type r> set-current |
does> ( item -- ) |
does> ( item -- ) |
Line 672 stack inst-stream IP Cell
|
Line 673 stack inst-stream IP Cell
|
|
|
: disasm-arg { item -- } |
: disasm-arg { item -- } |
item item-stack @ inst-stream = if |
item item-stack @ inst-stream = if |
." fputc(' ', vm_out); " |
." {" cr |
." printarg_" item item-type @ print-type-prefix |
item print-declaration |
." ((" item item-type @ type-c-name 2@ type ." )" |
item fetch |
." ip[" item item-offset @ 1+ 0 .r ." ]);" cr |
item print-debug-arg |
|
." }" cr |
endif ; |
endif ; |
|
|
: disasm-args ( -- ) |
: disasm-args ( -- ) |
Line 683 stack inst-stream IP Cell
|
Line 685 stack inst-stream IP Cell
|
|
|
: output-disasm ( -- ) |
: output-disasm ( -- ) |
\ generate code for disassembling VM instructions |
\ generate code for disassembling VM instructions |
." if (ip[0] == prim[" function-number @ 0 .r ." ]) {" cr |
." if (VM_IS_INST(*ip, " function-number @ 0 .r ." )) {" cr |
." fputs(" quote prim prim-name 2@ type quote ." , vm_out);" cr |
." fputs(" quote prim prim-name 2@ type quote ." , vm_out);" cr |
disasm-args |
disasm-args |
." ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr |
." ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr |
Line 693 stack inst-stream IP Cell
|
Line 695 stack inst-stream IP Cell
|
: output-profile ( -- ) |
: output-profile ( -- ) |
\ 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 |
." add_inst(b, " quote prim prim-name 2@ type quote ." );" cr |
." add_inst(b, " quote prim prim-name 2@ type quote ." );" cr |
." ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr |
." ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr |
prim prim-c-code 2@ s" SET_IP" search nip nip |
prim prim-c-code 2@ s" SET_IP" search nip nip |
prim prim-c-code 2@ s" SUPER_END" search nip nip or if |
prim prim-c-code 2@ s" SUPER_END" search nip nip or if |
Line 703 stack inst-stream IP Cell
|
Line 705 stack inst-stream IP Cell
|
endif |
endif |
." }" cr ; |
." }" cr ; |
|
|
|
: output-profile-combined ( -- ) |
|
\ generate code for postprocessing the VM block profile stuff |
|
." if (VM_IS_INST(*ip, " function-number @ 0 .r ." )) {" cr |
|
num-combined @ 0 +do |
|
." add_inst(b, " quote |
|
combined-prims i th @ prim-name 2@ type |
|
quote ." );" cr |
|
loop |
|
." 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" SUPER_END" search nip nip or if |
|
." return;" cr |
|
else |
|
." goto _endif_;" cr |
|
endif |
|
." }" cr ; |
|
|
|
: output-superend ( -- ) |
|
\ output flag specifying whether the current word ends a dynamic superinst |
|
prim prim-c-code 2@ s" SET_IP" search nip nip |
|
prim prim-c-code 2@ s" SUPER_END" search nip nip or 0<> |
|
prim prim-c-code 2@ s" SUPER_CONTINUE" search nip nip 0= and |
|
negate 0 .r ." , /* " prim prim-name 2@ type ." */" cr ; |
|
|
: gen-arg-parm { item -- } |
: gen-arg-parm { item -- } |
item item-stack @ inst-stream = if |
item item-stack @ inst-stream = if |
." , " item item-type @ type-c-name 2@ type space |
." , " item item-type @ type-c-name 2@ type space |
Line 1221 Variable c-flag
|
Line 1247 Variable c-flag
|
line @ name-line ! filename 2@ name-filename 2! |
line @ name-line ! filename 2@ name-filename 2! |
function-number @ prim prim-num ! |
function-number @ prim prim-num ! |
start }} forth-ident {{ end 2dup prim prim-name 2! prim prim-c-name 2! }} white ++ |
start }} forth-ident {{ end 2dup prim prim-name 2! prim prim-c-name 2! }} white ++ |
|
(( ` / white ** {{ start }} c-ident {{ end prim prim-c-name 2! }} white ** )) ?? |
(( simple-primitive || combined-primitive )) {{ 1 function-number +! }} |
(( simple-primitive || combined-primitive )) {{ 1 function-number +! }} |
)) <- primitive ( -- ) |
)) <- primitive ( -- ) |
|
|