version 1.1, 2003/09/08 13:05:15
|
version 1.4, 2003/10/01 09:15:45
|
Line 188 struct%
|
Line 188 struct%
|
cell% field type-store \ xt of store code generator ( item -- ) |
cell% field type-store \ xt of store code generator ( item -- ) |
end-struct type% |
end-struct type% |
|
|
|
struct% |
|
cell% field register-number |
|
cell% field register-type \ pointer to type |
|
cell% 2* field register-name \ c name |
|
end-struct register% |
|
|
|
struct% |
|
cell% 2* field ss-registers \ addr u; ss-registers[0] is TOS |
|
\ 0 means: use memory |
|
cell% field ss-offset \ stack pointer offset: sp[-offset] is TOS |
|
end-struct ss% \ stack-state |
|
|
|
struct% |
|
cell% max-stacks * field state-sss |
|
end-struct state% |
|
|
variable next-stack-number 0 next-stack-number ! |
variable next-stack-number 0 next-stack-number ! |
create stacks max-stacks cells allot \ array of stacks |
create stacks max-stacks cells allot \ array of stacks |
|
256 constant max-registers |
|
create registers max-registers cells allot \ array of registers |
|
variable nregisters 0 nregisters ! \ number of registers |
|
|
: stack-in-index ( in-size item -- in-index ) |
: stack-in-index ( in-size item -- in-index ) |
item-offset @ - 1- ; |
item-offset @ - 1- ; |
Line 269 end-struct prim%
|
Line 288 end-struct prim%
|
0 value combined \ in combined prims the combined prim |
0 value combined \ in combined prims the combined prim |
variable in-part \ true if processing a part |
variable in-part \ true if processing a part |
in-part off |
in-part off |
|
0 value state-in \ state on entering prim |
|
0 value state-out \ state on exiting prim |
|
|
: prim-context ( ... p xt -- ... ) |
: prim-context ( ... p xt -- ... ) |
\ execute xt with prim set to p |
\ execute xt with prim set to p |
Line 351 defer inst-stream-f ( -- stack )
|
Line 372 defer inst-stream-f ( -- stack )
|
\ stack access stuff |
\ stack access stuff |
|
|
: normal-stack-access0 { n stack -- } |
: normal-stack-access0 { n stack -- } |
|
\ n has the ss-offset already applied (see ...-access1) |
n stack stack-access-transform @ execute ." [" 0 .r ." ]" ; |
n stack stack-access-transform @ execute ." [" 0 .r ." ]" ; |
|
|
: normal-stack-access1 { n stack -- } |
: state-ss { stack state -- ss } |
stack stack-pointer 2@ type |
state state-sss stack stack-number @ th @ ; |
n if |
|
n stack normal-stack-access0 |
: stack-reg { n stack state -- reg } |
|
\ n is the index (TOS=0); reg is 0 if the access is to memory |
|
stack state state-ss ss-registers 2@ n u> if ( addr ) \ in ss-registers? |
|
n th @ |
else |
else |
." TOS" |
drop 0 |
endif ; |
endif ; |
|
|
: normal-stack-access ( n stack -- ) |
: normal-stack-access1 { n stack state -- } |
dup inst-stream-f = if |
n stack state stack-reg ?dup-if |
|
register-name 2@ type exit |
|
endif |
|
stack stack-pointer 2@ type |
|
n stack state state-ss ss-offset @ - stack normal-stack-access0 ; |
|
|
|
: normal-stack-access ( n stack state -- ) |
|
over inst-stream-f = if |
." IMM_ARG(" normal-stack-access1 ." ," immarg ? ." )" |
." IMM_ARG(" normal-stack-access1 ." ," immarg ? ." )" |
1 immarg +! |
1 immarg +! |
else |
else |
Line 391 defer inst-stream-f ( -- stack )
|
Line 423 defer inst-stream-f ( -- stack )
|
stack stack-number @ part-num @ s-c-max-depth @ |
stack stack-number @ part-num @ s-c-max-depth @ |
\ max-depth stack stack-number @ th @ ( ndepth nmaxdepth ) |
\ max-depth stack stack-number @ th @ ( ndepth nmaxdepth ) |
over <= if ( ndepth ) \ load from memory |
over <= if ( ndepth ) \ load from memory |
stack normal-stack-access |
stack state-in normal-stack-access |
else |
else |
drop n stack part-stack-access |
drop n stack part-stack-access |
endif ; |
endif ; |
Line 405 defer inst-stream-f ( -- stack )
|
Line 437 defer inst-stream-f ( -- stack )
|
stack stack-number @ part-num @ s-c-max-back-depth @ |
stack stack-number @ part-num @ s-c-max-back-depth @ |
over <= if ( ndepth ) |
over <= if ( ndepth ) |
stack combined ['] stack-diff prim-context - |
stack combined ['] stack-diff prim-context - |
stack normal-stack-access |
stack state-out normal-stack-access |
else |
else |
drop n stack part-stack-access |
drop n stack part-stack-access |
endif ; |
endif ; |
Line 415 defer inst-stream-f ( -- stack )
|
Line 447 defer inst-stream-f ( -- stack )
|
in-part @ if |
in-part @ if |
part-stack-read |
part-stack-read |
else |
else |
normal-stack-access |
state-in normal-stack-access |
endif ; |
endif ; |
|
|
: stack-write ( n stack -- ) |
: stack-write ( n stack -- ) |
Line 423 defer inst-stream-f ( -- stack )
|
Line 455 defer inst-stream-f ( -- stack )
|
in-part @ if |
in-part @ if |
part-stack-write |
part-stack-write |
else |
else |
normal-stack-access |
state-out normal-stack-access |
endif ; |
endif ; |
|
|
: item-in-index { item -- n } |
: item-in-index { item -- n } |
Line 474 defer inst-stream-f ( -- stack )
|
Line 506 defer inst-stream-f ( -- stack )
|
rdrop ; |
rdrop ; |
|
|
: item-out-index ( item -- n ) |
: item-out-index ( item -- n ) |
\ n is the index of item (in the in-effect) |
\ n is the index of item (in the out-effect) |
>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 -- ) |
Line 486 defer inst-stream-f ( -- stack )
|
Line 518 defer inst-stream-f ( -- stack )
|
r@ item-out-index r@ item-stack @ stack-write ." );" |
r@ item-out-index r@ item-stack @ stack-write ." );" |
rdrop ; |
rdrop ; |
|
|
: store-single ( item -- ) |
: store-single { item -- } |
>r |
item item-stack @ { stack } |
store-optimization @ in-part @ 0= and r@ same-as-in? and if |
store-optimization @ in-part @ 0= and item same-as-in? and |
r@ item-in-index 0= r@ item-out-index 0= xor if |
item item-in-index stack state-in stack-reg 0= and \ in in memory? |
." IF_" r@ item-stack @ stack-pointer 2@ type |
item item-out-index stack state-out stack-reg 0= and \ out in memory? |
." TOS(" r@ really-store-single ." );" cr |
0= if |
endif |
item really-store-single cr |
else |
endif ; |
r@ really-store-single cr |
|
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 614 does> ( item -- )
|
Line 643 does> ( item -- )
|
wordlist constant type-names \ this is here just to meet the requirement |
wordlist constant type-names \ this is here just to meet the requirement |
\ that a type be a word; it is never used for lookup |
\ that a type be a word; it is never used for lookup |
|
|
|
: define-type ( addr u -- xt ) |
|
\ define single type with name addr u, without stack |
|
get-current type-names set-current >r |
|
2dup nextname stack-type-name |
|
r> set-current |
|
latestxt ; |
|
|
: stack ( "name" "stack-pointer" "type" -- ) |
: stack ( "name" "stack-pointer" "type" -- ) |
\ define stack |
\ define stack |
name { d: stack-name } |
name { d: stack-name } |
name { d: stack-pointer } |
name { d: stack-pointer } |
name { d: stack-type } |
name { d: stack-type } |
get-current type-names set-current |
stack-type define-type |
stack-type 2dup nextname stack-type-name |
stack-pointer rot >body stack-name nextname make-stack ; |
set-current |
|
stack-pointer latestxt >body stack-name nextname make-stack ; |
|
|
|
stack inst-stream IP Cell |
stack inst-stream IP Cell |
' inst-in-index inst-stream stack-in-index-xt ! |
' inst-in-index inst-stream stack-in-index-xt ! |
' inst-stream <is> inst-stream-f |
' inst-stream <is> inst-stream-f |
\ !! initialize stack-in and stack-out |
\ !! initialize stack-in and stack-out |
|
|
|
\ registers |
|
|
|
: make-register ( type addr u -- ) |
|
\ define register with type TYPE and name ADDR U. |
|
nregisters @ max-registers < s" too many registers" ?print-error |
|
2dup nextname create register% %allot >r |
|
r@ register-name 2! |
|
r@ register-type ! |
|
nregisters @ r@ register-number ! |
|
1 nregisters +! |
|
rdrop ; |
|
|
|
: register ( "name" "type" -- ) |
|
\ define register |
|
name { d: reg-name } |
|
name { d: reg-type } |
|
reg-type define-type >body |
|
reg-name make-register ; |
|
|
|
\ stack-states |
|
|
|
: stack-state ( a-addr u uoffset "name" -- ) |
|
create ss% %allot >r |
|
r@ ss-offset ! |
|
r@ ss-registers 2! |
|
rdrop ; |
|
|
|
0 0 0 stack-state default-ss |
|
|
|
\ state |
|
|
|
: state ( "name" -- ) |
|
\ create a state initialized with default-sss |
|
create state% %allot state-sss { sss } |
|
max-stacks 0 ?do |
|
default-ss sss i th ! |
|
loop ; |
|
|
|
: set-ss ( ss stack state -- ) |
|
state-sss swap stack-number @ th ! ; |
|
|
\ offset computation |
\ offset computation |
\ the leftmost (i.e. deepest) item has offset 0 |
\ the leftmost (i.e. deepest) item has offset 0 |
\ the rightmost item has the highest offset |
\ the rightmost item has the highest offset |