version 1.118, 2002/10/12 11:05:22
|
version 1.123, 2002/12/27 15:51:28
|
Line 95 variable include-skipped-insts
|
Line 95 variable include-skipped-insts
|
\ inline arguments (false) |
\ inline arguments (false) |
include-skipped-insts off |
include-skipped-insts off |
|
|
|
variable immarg \ values for immediate arguments (to be used in IMM_ARG macros) |
|
$12340000 immarg ! |
|
|
: th ( addr1 n -- addr2 ) |
: th ( addr1 n -- addr2 ) |
cells + ; |
cells + ; |
|
|
Line 286 create min-depth max-stacks cells al
|
Line 289 create min-depth max-stacks cells al
|
create sp-update-in max-stacks cells allot |
create sp-update-in max-stacks cells allot |
\ where max-depth occured the first time |
\ where max-depth occured the first time |
create max-depths max-stacks max-combined 1+ * cells allot |
create max-depths max-stacks max-combined 1+ * cells allot |
\ maximum depth at start of each component: array[components] of array[stack] |
\ maximum depth at start of each part: array[parts] of array[stack] |
|
create max-back-depths max-stacks max-combined 1+ * cells allot |
|
\ maximun depth from end of the combination to the start of the each part |
|
|
: s-c-max-depth ( nstack ncomponent -- addr ) |
: s-c-max-depth ( nstack ncomponent -- addr ) |
max-stacks * + cells max-depths + ; |
max-stacks * + cells max-depths + ; |
|
|
|
: s-c-max-back-depth ( nstack ncomponent -- addr ) |
|
max-stacks * + cells max-back-depths + ; |
|
|
wordlist constant primitives |
wordlist constant primitives |
|
|
: create-prim ( prim -- ) |
: create-prim ( prim -- ) |
Line 320 Variable function-number 0 function-numb
|
Line 328 Variable function-number 0 function-numb
|
: complement ( set1 -- set2 ) |
: complement ( set1 -- set2 ) |
empty ['] bit-equivalent binary-set-operation ; |
empty ['] bit-equivalent binary-set-operation ; |
|
|
|
\ forward declaration for inst-stream (breaks cycle in definitions) |
|
defer inst-stream-f ( -- stack ) |
|
|
\ stack access stuff |
\ stack access stuff |
|
|
: normal-stack-access ( n stack -- ) |
: normal-stack-access1 ( n stack -- ) |
stack-pointer 2@ type |
stack-pointer 2@ type |
dup |
dup |
if |
if |
Line 331 Variable function-number 0 function-numb
|
Line 342 Variable function-number 0 function-numb
|
drop ." TOS" |
drop ." TOS" |
endif ; |
endif ; |
|
|
\ forward declaration for inst-stream (breaks cycle in definitions) |
: normal-stack-access ( n stack -- ) |
defer inst-stream-f ( -- stack ) |
dup inst-stream-f = if |
|
." IMM_ARG(" normal-stack-access1 ." ," immarg ? ." )" |
|
1 immarg +! |
|
else |
|
normal-stack-access1 |
|
endif ; |
|
|
: stack-depth { stack -- n } |
: stack-depth { stack -- n } |
current-depth stack stack-number @ th @ ; |
current-depth stack stack-number @ th @ ; |
Line 361 defer inst-stream-f ( -- stack )
|
Line 377 defer inst-stream-f ( -- stack )
|
drop n stack part-stack-access |
drop n stack part-stack-access |
endif ; |
endif ; |
|
|
: part-stack-write ( n stack -- ) |
: stack-diff ( stack -- n ) |
part-stack-access ; |
\ in-out |
|
dup stack-in @ swap stack-out @ - ; |
|
|
|
: part-stack-write { n stack -- } |
|
stack stack-depth n + |
|
stack stack-number @ part-num @ s-c-max-back-depth @ |
|
over <= if ( ndepth ) |
|
stack combined ['] stack-diff prim-context - |
|
stack normal-stack-access |
|
else |
|
drop n stack part-stack-access |
|
endif ; |
|
|
: stack-read ( n stack -- ) |
: stack-read ( n stack -- ) |
\ print a stack access at index n of stack |
\ print a stack access at index n of stack |
Line 641 stack inst-stream IP Cell
|
Line 668 stack inst-stream IP Cell
|
: fetches ( -- ) |
: fetches ( -- ) |
prim prim-effect-in prim prim-effect-in-end @ ['] fetch map-items ; |
prim prim-effect-in prim prim-effect-in-end @ ['] fetch map-items ; |
|
|
: inst-pointer-update ( -- ) |
|
inst-stream stack-in @ ?dup-if |
|
." INC_IP(" 0 .r ." );" cr |
|
endif ; |
|
|
|
: stack-pointer-update { stack -- } |
: stack-pointer-update { stack -- } |
\ stack grow downwards |
\ stacks grow downwards |
stack stack-in @ stack stack-out @ - |
stack stack-diff |
?dup-if \ this check is not necessary, gcc would do this for us |
?dup-if \ this check is not necessary, gcc would do this for us |
stack inst-stream = if |
stack inst-stream = if |
inst-pointer-update |
." INC_IP(" 0 .r ." );" cr |
else |
else |
stack stack-pointer 2@ type ." += " 0 .r ." ;" cr |
stack stack-pointer 2@ type ." += " 0 .r ." ;" cr |
endif |
endif |
Line 702 stack inst-stream IP Cell
|
Line 724 stack inst-stream IP Cell
|
endif |
endif |
2drop ; |
2drop ; |
|
|
: output-c-tail1 ( -- ) |
: output-label2 ( -- ) |
\ the final part of the generated C code except LABEL2 and NEXT_P2 |
." LABEL2(" prim prim-c-name 2@ type ." )" cr |
|
." NEXT_P2;" cr ; |
|
|
|
: output-c-tail1 { xt -- } |
|
\ 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 |
." NEXT_P1;" cr |
stores |
stores |
fill-tos ; |
fill-tos |
|
xt execute ; |
|
|
|
: output-c-tail1-no-stores { xt -- } |
|
\ the final part of the generated C code for combinations |
|
output-super-end |
|
." NEXT_P1;" cr |
|
fill-tos |
|
xt execute ; |
|
|
: output-c-tail ( -- ) |
: output-c-tail ( -- ) |
\ the final part of the generated C code, without LABEL2 |
['] noop output-c-tail1 ; |
output-c-tail1 |
|
." NEXT_P2;" ; |
|
|
|
: output-c-tail2 ( -- ) |
: output-c-tail2 ( -- ) |
\ the final part of the generated C code, including LABEL2 |
['] output-label2 output-c-tail1 ; |
output-c-tail1 |
|
." LABEL2(" prim prim-c-name 2@ type ." )" cr |
: output-c-tail-no-stores ( -- ) |
." NEXT_P2;" cr ; |
['] noop output-c-tail1-no-stores ; |
|
|
|
: output-c-tail2-no-stores ( -- ) |
|
['] output-label2 output-c-tail1-no-stores ; |
|
|
: 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 |
Line 887 stack inst-stream IP Cell
|
Line 922 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 ( -- ) |
: output-c-prim-num ( -- ) |
prim prim-num @ 8 + 4 .r space prim prim-name 2@ type cr ; |
." #define N_" prim prim-c-name 2@ type prim prim-num @ 8 + 4 .r cr ; |
|
|
: output-forth ( -- ) |
: output-forth ( -- ) |
prim prim-forth-code @ 0= |
prim prim-forth-code @ 0= |
Line 1013 stack inst-stream IP Cell
|
Line 1048 stack inst-stream IP Cell
|
: min! ( n addr -- ) |
: min! ( n addr -- ) |
tuck @ min swap ! ; |
tuck @ min swap ! ; |
|
|
: inst-stream-correction ( nin1 nstack -- nin2 ) |
: inst-stream-adjustment ( nstack -- n ) |
0= if |
\ number of stack items to add for each part |
include-skipped-insts @ - |
0= include-skipped-insts @ and negate ; |
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 @ + i inst-stream-correction |
p prim-stacks-in i th @ + i inst-stream-adjustment + |
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 1073 stack inst-stream IP Cell
|
Line 1107 stack inst-stream IP Cell
|
i q prim-stacks-out i th @ q prim-effect-out-end make-effect-items |
i q prim-stacks-out i th @ q prim-effect-out-end make-effect-items |
loop ; |
loop ; |
|
|
|
: compute-stack-max-back-depths ( stack -- ) |
|
stack-number @ { stack# } |
|
current-depth stack# th @ dup |
|
dup stack# num-combined @ s-c-max-back-depth ! |
|
-1 num-combined @ 1- -do ( max-depth current-depth ) |
|
combined-prims i th @ { p } |
|
p prim-stacks-out stack# th @ + |
|
dup >r max r> |
|
over stack# i s-c-max-back-depth ! |
|
p prim-stacks-in stack# th @ - |
|
stack# inst-stream-adjustment - |
|
1 -loop |
|
assert( dup stack# inst-stream-adjustment negate = ) |
|
assert( over max-depth stack# th @ = ) |
|
2drop ; |
|
|
|
: compute-max-back-depths ( -- ) |
|
\ compute max-back-depths. |
|
\ assumes that current-depths is correct for the end of the combination |
|
['] compute-stack-max-back-depths map-stacks ; |
|
|
: process-combined ( -- ) |
: process-combined ( -- ) |
combined combined-prims num-combined @ cells |
combined combined-prims num-combined @ cells |
combinations ['] constant insert-wordlist |
combinations ['] constant insert-wordlist |
Line 1080 stack inst-stream IP Cell
|
Line 1135 stack inst-stream IP Cell
|
@ prim-c-code 2@ prim prim-c-code 2! \ used by output-super-end |
@ prim-c-code 2@ prim prim-c-code 2! \ used by output-super-end |
prim compute-effects |
prim compute-effects |
prim init-effects |
prim init-effects |
|
compute-max-back-depths |
output-combined perform ; |
output-combined perform ; |
|
|
\ C output |
\ C output |
Line 1106 stack inst-stream IP Cell
|
Line 1162 stack inst-stream IP Cell
|
: output-combined-tail ( -- ) |
: output-combined-tail ( -- ) |
part-output-c-tail |
part-output-c-tail |
in-part @ >r in-part off |
in-part @ >r in-part off |
combined ['] output-c-tail prim-context |
combined ['] output-c-tail-no-stores prim-context |
r> in-part ! ; |
r> in-part ! ; |
|
|
: part-stack-pointer-updates ( -- ) |
: part-stack-pointer-updates ( -- ) |
max-stacks 0 +do |
next-stack-number @ 0 +do |
i part-num @ 1+ s-c-max-depth @ dup |
i part-num @ 1+ s-c-max-depth @ dup |
i num-combined @ s-c-max-depth @ = \ final depth |
i num-combined @ s-c-max-depth @ = \ final depth |
swap i part-num @ s-c-max-depth @ <> \ just reached now |
swap i part-num @ s-c-max-depth @ <> \ just reached now |
Line 1155 stack inst-stream IP Cell
|
Line 1211 stack inst-stream IP Cell
|
\ print-debug-args |
\ print-debug-args |
\ stack-pointer-updates now in parts |
\ stack-pointer-updates now in parts |
output-parts |
output-parts |
output-c-tail2 |
output-c-tail2-no-stores |
." }" cr |
." }" cr |
cr ; |
cr ; |
|
|