| 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 -- ) |
| 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-superend ( -- ) |
| \ output flag specifying whether the current word ends a dynamic superinst |
\ 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" SET_IP" search nip nip |
| 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 ( -- ) |
| |
|
