version 1.144, 2003/10/09 14:15:19
|
version 1.155, 2005/01/26 21:24:15
|
Line 1
|
Line 1
|
\ converts primitives to, e.g., C code |
\ converts primitives to, e.g., C code |
|
|
\ Copyright (C) 1995,1996,1997,1998,2000,2003 Free Software Foundation, Inc. |
\ Copyright (C) 1995,1996,1997,1998,2000,2003,2004 Free Software Foundation, Inc. |
|
|
\ This file is part of Gforth. |
\ This file is part of Gforth. |
|
|
Line 267 struct%
|
Line 267 struct%
|
cell% 2* field prim-name |
cell% 2* field prim-name |
cell% 2* field prim-wordset |
cell% 2* field prim-wordset |
cell% 2* field prim-c-name |
cell% 2* field prim-c-name |
|
cell% 2* field prim-c-name-orig \ for reprocessed prims, the original name |
cell% 2* field prim-doc |
cell% 2* field prim-doc |
cell% 2* field prim-c-code |
cell% 2* field prim-c-code |
cell% 2* field prim-forth-code |
cell% 2* field prim-forth-code |
Line 302 variable in-part \ true if processing a
|
Line 303 variable in-part \ true if processing a
|
r> to prim |
r> to prim |
throw ; |
throw ; |
|
|
|
: prim-c-name-2! ( c-addr u -- ) |
|
2dup prim prim-c-name 2! prim prim-c-name-orig 2! ; |
|
|
1000 constant max-combined |
1000 constant max-combined |
create combined-prims max-combined cells allot |
create combined-prims max-combined cells allot |
variable num-combined |
variable num-combined |
Line 531 defer inst-stream-f ( -- stack )
|
Line 535 defer inst-stream-f ( -- stack )
|
: store-single { item -- } |
: store-single { item -- } |
item item-stack @ { stack } |
item item-stack @ { stack } |
store-optimization @ in-part @ 0= and item same-as-in? and |
store-optimization @ in-part @ 0= and item same-as-in? and |
item item-in-index stack state-in stack-reg 0= and \ in in memory? |
item item-in-index stack state-in stack-reg \ in reg/mem |
item item-out-index stack state-out stack-reg 0= and \ out in memory? |
item item-out-index stack state-out stack-reg = and \ out reg/mem |
0= if |
0= if |
item really-store-single cr |
item really-store-single cr |
endif ; |
endif ; |
Line 712 stack inst-stream IP Cell
|
Line 716 stack inst-stream IP Cell
|
default-ss s state-sss i th ! |
default-ss s state-sss i th ! |
loop ; |
loop ; |
|
|
|
: .state ( state -- ) |
|
0 >body - >name .name ; |
|
|
: set-ss ( ss stack state -- ) |
: set-ss ( ss stack state -- ) |
state-sss swap stack-number @ th ! ; |
state-sss swap stack-number @ th ! ; |
|
|
Line 887 stack inst-stream IP Cell
|
Line 894 stack inst-stream IP Cell
|
endif |
endif |
2drop ; |
2drop ; |
|
|
|
|
|
defer output-nextp0 |
|
:noname ( -- ) |
|
." NEXT_P0;" cr ; |
|
is output-nextp0 |
|
|
|
defer output-nextp1 |
|
:noname ( -- ) |
|
." NEXT_P1;" cr ; |
|
is output-nextp1 |
|
|
: output-nextp2 ( -- ) |
: output-nextp2 ( -- ) |
." NEXT_P2;" cr ; |
." NEXT_P2;" cr ; |
|
|
Line 895 variable tail-nextp2 \ xt to execute for
|
Line 913 variable tail-nextp2 \ xt to execute for
|
|
|
: output-label2 ( -- ) |
: output-label2 ( -- ) |
." LABEL2(" prim prim-c-name 2@ type ." )" cr |
." LABEL2(" prim prim-c-name 2@ type ." )" cr |
." NEXT_P2;" cr ; |
." NEXT_P1_5;" cr |
|
." LABEL3(" prim prim-c-name 2@ type ." )" cr |
|
." DO_GOTO;" cr ; |
|
|
: output-c-tail1 { xt -- } |
: output-c-tail1 { xt -- } |
\ the final part of the generated C code, with xt printing LABEL2 or not. |
\ the final part of the generated C code, with xt printing LABEL2 or not. |
output-super-end |
output-super-end |
print-debug-results |
print-debug-results |
." NEXT_P1;" cr |
output-nextp1 |
stores |
stores |
fill-state |
fill-state |
xt execute ; |
xt execute ; |
|
|
|
: output-c-vm-jump-tail ( -- ) |
|
\ !! this functionality not yet implemented for superinstructions |
|
output-super-end |
|
print-debug-results |
|
stores |
|
fill-state |
|
." LABEL2(" prim prim-c-name 2@ type ." )" cr |
|
." LABEL3(" prim prim-c-name 2@ type ." )" cr |
|
." DO_GOTO;" cr ; |
|
|
: output-c-tail1-no-stores { xt -- } |
: output-c-tail1-no-stores { xt -- } |
\ the final part of the generated C code for combinations |
\ the final part of the generated C code for combinations |
output-super-end |
output-super-end |
." NEXT_P1;" cr |
output-nextp1 |
fill-state |
fill-state |
xt execute ; |
xt execute ; |
|
|
Line 917 variable tail-nextp2 \ xt to execute for
|
Line 947 variable tail-nextp2 \ xt to execute for
|
tail-nextp2 @ output-c-tail1 ; |
tail-nextp2 @ output-c-tail1 ; |
|
|
: output-c-tail2 ( -- ) |
: output-c-tail2 ( -- ) |
['] output-label2 output-c-tail1 ; |
prim prim-c-code 2@ s" VM_JUMP(" search nip nip if |
|
output-c-vm-jump-tail |
|
else |
|
['] output-label2 output-c-tail1 |
|
endif ; |
|
|
: output-c-tail-no-stores ( -- ) |
: output-c-tail-no-stores ( -- ) |
tail-nextp2 @ output-c-tail1-no-stores ; |
tail-nextp2 @ output-c-tail1-no-stores ; |
Line 944 variable tail-nextp2 \ xt to execute for
|
Line 978 variable tail-nextp2 \ xt to execute for
|
|
|
: print-entry ( -- ) |
: print-entry ( -- ) |
." LABEL(" prim prim-c-name 2@ type ." )" ; |
." LABEL(" prim prim-c-name 2@ type ." )" ; |
|
|
|
: prim-type ( addr u -- ) |
|
\ print out a primitive, but avoid "*/" |
|
2dup s" */" search nip nip IF |
|
bounds ?DO I c@ dup '* = IF drop 'x THEN emit LOOP |
|
ELSE type THEN ; |
|
|
: output-c ( -- ) |
: output-c ( -- ) |
print-entry ." /* " prim prim-name 2@ type ." ( " prim prim-stack-string 2@ type ." ) */" cr |
print-entry ." /* " prim prim-name 2@ prim-type |
|
." ( " prim prim-stack-string 2@ type ." ) " |
|
state-in .state ." -- " state-out .state ." */" 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 |
output-nextp0 |
spill-state |
spill-state |
fetches |
fetches |
print-debug-args |
print-debug-args |
Line 1024 variable tail-nextp2 \ xt to execute for
|
Line 1066 variable tail-nextp2 \ xt to execute for
|
prim prim-branch? |
prim prim-branch? |
prim prim-c-code 2@ s" SUPER_END" search nip nip 0<> or |
prim prim-c-code 2@ s" SUPER_END" search nip nip 0<> or |
prim prim-c-code 2@ s" SUPER_CONTINUE" search nip nip 0= and |
prim prim-c-code 2@ s" SUPER_CONTINUE" search nip nip 0= and |
negate 0 .r ." , /* " prim prim-name 2@ type ." */" cr ; |
negate 0 .r ." , /* " prim prim-name 2@ prim-type ." */" cr ; |
|
|
: gen-arg-parm { item -- } |
: gen-arg-parm { item -- } |
item item-stack @ inst-stream = if |
item item-stack @ inst-stream = if |
Line 1095 variable tail-nextp2 \ xt to execute for
|
Line 1137 variable tail-nextp2 \ xt to execute for
|
: 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-c-prim-num ( -- ) |
defer output-c-prim-num ( -- ) |
|
|
|
:noname ( -- ) |
." N_" prim prim-c-name 2@ type ." ," cr ; |
." N_" prim prim-c-name 2@ type ." ," cr ; |
|
is output-c-prim-num |
|
|
: output-forth ( -- ) |
: output-forth ( -- ) |
prim prim-forth-code @ 0= |
prim prim-forth-code @ 0= |
Line 1427 variable reprocessed-num 0 reprocessed-n
|
Line 1472 variable reprocessed-num 0 reprocessed-n
|
|
|
: output-part ( p -- ) |
: output-part ( p -- ) |
to prim |
to prim |
." /* " prim prim-name 2@ type ." ( " prim prim-stack-string 2@ type ." ) */" cr |
." /* " prim prim-name 2@ prim-type ." ( " prim prim-stack-string 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 |
print-declarations |
print-declarations |
Line 1454 variable reprocessed-num 0 reprocessed-n
|
Line 1499 variable reprocessed-num 0 reprocessed-n
|
." {" cr |
." {" cr |
." DEF_CA" cr |
." DEF_CA" cr |
print-declarations-combined |
print-declarations-combined |
." NEXT_P0;" cr |
output-nextp0 |
spill-state |
spill-state |
\ fetches \ now in parts |
\ fetches \ now in parts |
\ print-debug-args |
\ print-debug-args |
Line 1494 variable reprocessed-num 0 reprocessed-n
|
Line 1539 variable reprocessed-num 0 reprocessed-n
|
\ This is intended as initializer for a structure like this |
\ This is intended as initializer for a structure like this |
|
|
\ struct cost { |
\ struct cost { |
\ int loads; /* number of stack loads */ |
\ char loads; /* number of stack loads */ |
\ int stores; /* number of stack stores */ |
\ char stores; /* number of stack stores */ |
\ int updates; /* number of stack pointer updates */ |
\ char updates; /* number of stack pointer updates */ |
\ int offset; /* offset into super2 table */ |
\ char branch; /* is it a branch (SET_IP) */ |
\ int length; /* number of components */ |
\ char state_in; /* state on entry */ |
|
\ char state_out; /* state on exit */ |
|
\ short offset; /* offset into super2 table */ |
|
\ char length; /* number of components */ |
\ }; |
\ }; |
|
|
\ How do you know which primitive or combined instruction this |
\ How do you know which primitive or combined instruction this |
Line 1528 variable reprocessed-num 0 reprocessed-n
|
Line 1576 variable reprocessed-num 0 reprocessed-n
|
loop ; |
loop ; |
|
|
: output-num-part ( p -- ) |
: output-num-part ( p -- ) |
." N_" prim-c-name 2@ type ." ," ; |
." N_" prim-c-name-orig 2@ type ." ," ; |
\ prim-num @ 4 .r ." ," ; |
\ prim-num @ 4 .r ." ," ; |
|
|
: output-name-comment ( -- ) |
: output-name-comment ( -- ) |
." /* " prim prim-name 2@ type ." */" ; |
." /* " prim prim-name 2@ prim-type ." */" ; |
|
|
variable offset-super2 0 offset-super2 ! \ offset into the super2 table |
variable offset-super2 0 offset-super2 ! \ offset into the super2 table |
|
|
Line 1541 variable offset-super2 0 offset-super2
|
Line 1589 variable offset-super2 0 offset-super2
|
rot 2 .r ." ," swap 2 .r ." ," 2 .r ." , " |
rot 2 .r ." ," swap 2 .r ." ," 2 .r ." , " |
prim prim-branch? negate . ." ," |
prim prim-branch? negate . ." ," |
state-in state-number @ 2 .r ." ," |
state-in state-number @ 2 .r ." ," |
state-out state-number @ 2 .r ." ," ; |
state-out state-number @ 2 .r ." ," |
|
inst-stream stack-in @ 1 .r ." ," |
|
; |
|
|
: output-costs-gforth-simple ( -- ) |
: output-costs-gforth-simple ( -- ) |
output-costs-prefix |
output-costs-prefix |
Line 1557 variable offset-super2 0 offset-super2
|
Line 1607 variable offset-super2 0 offset-super2
|
output-name-comment |
output-name-comment |
cr ; |
cr ; |
|
|
: output-costs ( -- ) |
\ : output-costs ( -- ) |
\ description of superinstructions and simple instructions |
\ \ description of superinstructions and simple instructions |
." {" prim compute-costs |
\ ." {" prim compute-costs |
rot 2 .r ." ," swap 2 .r ." ," 2 .r ." ," |
\ rot 2 .r ." ," swap 2 .r ." ," 2 .r ." ," |
offset-super2 @ 5 .r ." ," |
\ offset-super2 @ 5 .r ." ," |
super2-length dup 2 .r ." }," offset-super2 +! |
\ super2-length dup 2 .r ." ," offset-super2 +! |
output-name-comment |
\ inst-stream stack-in @ 1 .r ." }," |
cr ; |
\ output-name-comment |
|
\ cr ; |
|
|
: output-super2 ( -- ) |
: output-super2-simple ( -- ) |
\ table of superinstructions without requirement for existing prefixes |
prim prim-c-name 2@ prim prim-c-name-orig 2@ d= if |
combined if |
|
['] output-num-part map-combined |
|
else |
|
prim output-num-part |
prim output-num-part |
endif |
output-name-comment |
|
cr |
|
endif ; |
|
|
|
: output-super2-combined ( -- ) |
|
['] output-num-part map-combined |
output-name-comment |
output-name-comment |
cr ; |
cr ; |
|
|
Line 1733 Variable c-flag
|
Line 1786 Variable c-flag
|
(( {{ prim create-prim }} |
(( {{ prim create-prim }} |
` ( white ** {{ start }} stack-effect {{ end prim prim-stack-string 2! }} ` ) white ** |
` ( white ** {{ start }} stack-effect {{ end prim prim-stack-string 2! }} ` ) white ** |
(( {{ start }} forth-ident {{ end prim prim-wordset 2! }} white ** |
(( {{ start }} forth-ident {{ end prim prim-wordset 2! }} white ** |
(( {{ start }} c-ident {{ end prim prim-c-name 2! }} )) ?? |
(( {{ start }} c-ident {{ end 2dup prim-c-name-2! }} )) ?? |
)) ?? nleof |
)) ?? nleof |
(( ` " ` " {{ start }} (( noquote ++ ` " )) ++ {{ end 1- prim prim-doc 2! }} ` " white ** nleof )) ?? |
(( ` " ` " {{ start }} (( noquote ++ ` " )) ++ {{ end 1- prim prim-doc 2! }} ` " white ** nleof )) ?? |
{{ skipsynclines off line @ c-line ! filename 2@ c-filename 2! start }} |
{{ skipsynclines off line @ c-line ! filename 2@ c-filename 2! start }} |
Line 1755 Variable c-flag
|
Line 1808 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 }} [ifdef] vmgen c-ident [else] forth-ident [then] {{ end |
start }} [ifdef] vmgen c-ident [else] forth-ident [then] {{ end |
2dup prim prim-name 2! prim prim-c-name 2! }} white ** |
2dup prim prim-name 2! prim-c-name-2! }} white ** |
(( ` / white ** {{ start }} c-ident {{ end prim prim-c-name 2! }} white ** )) ?? |
(( ` / white ** {{ start }} c-ident {{ end prim-c-name-2! }} white ** )) ?? |
(( simple-primitive || combined-primitive )) |
(( simple-primitive || combined-primitive )) |
{{ 1 function-number +! }} |
{{ 1 function-number +! }} |
)) <- primitive ( -- ) |
)) <- primitive ( -- ) |