[BACK]Return to prims2y.fs CVS log [TXT] [DIR] Up to [gforth] / gforth

Diff for /gforth/Attic/prims2y.fs between versions 1.3 and 1.8

version 1.3, 2003/09/29 20:51:16 version 1.8, 2003/10/08 17:51:56
Line 201  struct% Line 201  struct%
 end-struct ss% \ stack-state  end-struct ss% \ stack-state
   
 struct%  struct%
       cell%              field state-number
     cell% max-stacks * field state-sss      cell% max-stacks * field state-sss
 end-struct state%  end-struct state%
   
Line 209  create stacks max-stacks cells allot \ a Line 210  create stacks max-stacks cells allot \ a
 256 constant max-registers  256 constant max-registers
 create registers max-registers cells allot \ array of registers  create registers max-registers cells allot \ array of registers
 variable nregisters 0 nregisters ! \ number of registers  variable nregisters 0 nregisters ! \ number of registers
   variable next-state-number 0 next-state-number ! \ next state number
   
 : stack-in-index ( in-size item -- in-index )  : stack-in-index ( in-size item -- in-index )
     item-offset @ - 1- ;      item-offset @ - 1- ;
Line 290  variable in-part \ true if processing a Line 292  variable in-part \ true if processing a
  in-part off   in-part off
 0 value state-in  \ state on entering prim  0 value state-in  \ state on entering prim
 0 value state-out \ state on exiting prim  0 value state-out \ state on exiting prim
   0 value state-default  \ canonical state at bb boundaries
   
 : prim-context ( ... p xt -- ... )  : prim-context ( ... p xt -- ... )
     \ execute xt with prim set to p      \ execute xt with prim set to p
Line 374  defer inst-stream-f ( -- stack ) Line 377  defer inst-stream-f ( -- stack )
 : normal-stack-access0 { n stack -- }  : normal-stack-access0 { n stack -- }
     \ n has the ss-offset already applied (see ...-access1)      \ 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 ." ]" ;
       
   : state-ss { stack state -- ss }
       state state-sss stack stack-number @ th @ ;
   
   : 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
           drop 0
       endif ;
   
   : .reg ( reg -- )
       register-name 2@ type ;
   
   : stack-offset ( stack state -- n )
       \ offset for stack in state
       state-ss ss-offset @ ;
   
 : normal-stack-access1 { n stack state -- }  : normal-stack-access1 { n stack state -- }
     state state-sss stack stack-number @ th @ { ss }      n stack state stack-reg ?dup-if
     ss ss-registers 2@ n u> if ( addr ) \ in ss-registers?          .reg exit
         n th @ dup if ( register ) \ and is ss-registers[n] a register?  
             \ then use the register  
             register-name 2@ type exit  
         endif  
     endif      endif
     drop  
     stack stack-pointer 2@ type      stack stack-pointer 2@ type
     n ss ss-offset @ - stack normal-stack-access0 ;      n stack state stack-offset - stack normal-stack-access0 ;
   
 : normal-stack-access ( n stack state -- )  : normal-stack-access ( n stack state -- )
     over inst-stream-f = if      over inst-stream-f = if
Line 500  defer inst-stream-f ( -- stack ) Line 516  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 512  defer inst-stream-f ( -- stack ) Line 528  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 693  stack inst-stream IP Cell Line 706  stack inst-stream IP Cell
   
 : state ( "name" -- )  : state ( "name" -- )
     \ create a state initialized with default-sss      \ create a state initialized with default-sss
     create state% %allot state-sss { sss }      create state% %allot { s }
       next-state-number @ s state-number ! 1 next-state-number +!
     max-stacks 0 ?do      max-stacks 0 ?do
         default-ss sss i th !          default-ss s state-sss i th !
     loop ;      loop ;
   
 : set-ss ( ss stack state -- )  : set-ss ( ss stack state -- )
Line 730  stack inst-stream IP Cell Line 744  stack inst-stream IP Cell
     declarations compute-offsets      declarations compute-offsets
     output @ execute ;      output @ execute ;
   
 : flush-a-tos { stack -- }  : stack-state-items ( stack state -- n )
     stack stack-out @ 0<> stack stack-in @ 0= and      state-ss ss-registers 2@ nip ;
     if  
         ." IF_" stack stack-pointer 2@ 2dup type ." TOS("  
         2dup type 0 stack normal-stack-access0 ."  = " type ." TOS);" cr  
     endif ;  
   
 : flush-tos ( -- )  : unused-stack-items { stack -- n-in n-out }
     ['] flush-a-tos map-stacks1 ;      \ n-in  are the stack items in state-in  not used    by prim
       \ n-out are the stack items in state-out not written by prim
       stack state-in  stack-state-items stack stack-in  @ - 0 max
       stack state-out stack-state-items stack stack-out @ - 0 max ;
   
   : spill-stack { stack -- }
       \ spill regs of state-in that are not used by prim and are not in state-out
       stack state-in stack-offset { offset }
       stack state-in stack-state-items ( items )
       dup stack unused-stack-items - - +do
           \ loop through the bottom items
           stack stack-pointer 2@ type
           i offset - stack normal-stack-access0 ."  = "
           i stack state-in normal-stack-access1 ." ;" cr
       loop ;
   
 : fill-a-tos { stack -- }  : spill-state ( -- )
     stack stack-out @ 0= stack stack-in @ 0<> and      ['] spill-stack map-stacks1 ;
     if  
         ." IF_" stack stack-pointer 2@ 2dup type ." TOS("  : fill-stack { stack -- }
         2dup type ." TOS = " type 0 stack normal-stack-access0 ." );" cr      stack state-out stack-offset { offset }
     endif ;      stack state-out stack-state-items ( items )
       dup stack unused-stack-items - + +do
           \ loop through the bottom items
           i stack state-out normal-stack-access1 ."  = "
           stack stack-pointer 2@ type
           i offset - stack normal-stack-access0 ." ;" cr
       loop ;
   
 : fill-tos ( -- )  : fill-state ( -- )
     \ !! inst-stream for prefetching?      \ !! inst-stream for prefetching?
     ['] fill-a-tos map-stacks1 ;      ['] fill-stack map-stacks1 ;
   
 : fetch ( addr -- )  : fetch ( addr -- )
     dup item-type @ type-fetch @ execute ;      dup item-type @ type-fetch @ execute ;
Line 757  stack inst-stream IP Cell Line 787  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 ;
   
   : reg-reg-move ( reg-from reg-to -- )
       2dup = if
           2drop
       else
           .reg ."  = " .reg ." ;" cr
       endif ;
   
   : stack-bottom-reg { n stack state -- reg }
       stack state stack-state-items n - 1- stack state stack-reg ;
   
   : stack-moves { stack -- }
       \ generate moves between registers in state-in/state-out that are
       \ not spilled or consumed/produced by prim.
       \ !! this works only for a simple stack cache, not e.g., for
       \ rotating stack caches, or registers shared between stacks (the
       \ latter would also require a change in interface)
       \ !! maybe place this after NEXT_P1?
       stack unused-stack-items 2dup < if ( n-in n-out )
           \ move registers from 0..n_in-1 to n_out-n_in..n_out-1
           over - { diff } ( n-in )
           -1 swap 1- -do
               i stack state-in stack-bottom-reg ( reg-from )
               i diff + stack state-out stack-bottom-reg reg-reg-move
           1 -loop
       else
           \ move registers from n_in-n_out..n_in-1 to 0..n_out-1
           swap over - { diff } ( n-out )
           0 +do
               i diff + stack state-in stack-bottom-reg ( reg-from )
               i stack state-out stack-bottom-reg reg-reg-move
           loop
       endif ;
   
 : stack-update-transform ( n1 stack -- n2 )  : stack-update-transform ( n1 stack -- n2 )
     \ n2 is the number by which the stack pointer should be      \ n2 is the number by which the stack pointer should be
     \ incremented to pop n1 items      \ incremented to pop n1 items
Line 764  stack inst-stream IP Cell Line 827  stack inst-stream IP Cell
     0 r> execute - ;      0 r> execute - ;
   
 : stack-pointer-update { stack -- }  : stack-pointer-update { stack -- }
       \ and moves
     \ stacks grow downwards      \ stacks grow downwards
     stack stack-diff      stack stack-diff ( in-out )
       stack state-in  stack-offset -
       stack state-out stack-offset + ( [in-in_offset]-[out-out_offset] )
     ?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
             ." INC_IP(" 0 .r ." );" cr              ." INC_IP(" 0 .r ." );" cr
Line 773  stack inst-stream IP Cell Line 839  stack inst-stream IP Cell
             stack stack-pointer 2@ type ."  += "              stack stack-pointer 2@ type ."  += "
             stack stack-update-transform 0 .r ." ;" cr              stack stack-update-transform 0 .r ." ;" cr
         endif          endif
     endif ;      endif
       stack stack-moves ;
   
 : stack-pointer-updates ( -- )  : stack-pointer-updates ( -- )
     ['] stack-pointer-update map-stacks ;      ['] stack-pointer-update map-stacks ;
Line 836  variable tail-nextp2 \ xt to execute for Line 903  variable tail-nextp2 \ xt to execute for
     print-debug-results      print-debug-results
     ." NEXT_P1;" cr      ." NEXT_P1;" cr
     stores      stores
     fill-tos       fill-state 
     xt execute ;      xt execute ;
   
 : 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      ." NEXT_P1;" cr
     fill-tos       fill-state 
     xt execute ;      xt execute ;
   
 : output-c-tail ( -- )  : output-c-tail ( -- )
Line 886  variable tail-nextp2 \ xt to execute for Line 953  variable tail-nextp2 \ xt to execute for
     ." DEF_CA" cr      ." DEF_CA" cr
     print-declarations      print-declarations
     ." NEXT_P0;" cr      ." NEXT_P0;" cr
     flush-tos      spill-state
     fetches      fetches
     print-debug-args      print-debug-args
     stack-pointer-updates      stack-pointer-updates
Line 1008  variable tail-nextp2 \ xt to execute for Line 1075  variable tail-nextp2 \ xt to execute for
 \      data-stack   stack-used? IF ." Cell *sp=SP;" cr THEN  \      data-stack   stack-used? IF ." Cell *sp=SP;" cr THEN
 \      fp-stack     stack-used? IF ." Cell *fp=*FP;" cr THEN  \      fp-stack     stack-used? IF ." Cell *fp=*FP;" cr THEN
 \      return-stack stack-used? IF ." Cell *rp=*RP;" cr THEN  \      return-stack stack-used? IF ." Cell *rp=*RP;" cr THEN
 \      flush-tos  \      spill-state
 \      fetches  \      fetches
 \      stack-pointer-updates  \      stack-pointer-updates
 \      fp-stack   stack-used? IF ." *FP=fp;" cr THEN  \      fp-stack   stack-used? IF ." *FP=fp;" cr THEN
Line 1017  variable tail-nextp2 \ xt to execute for Line 1084  variable tail-nextp2 \ xt to execute for
 \      prim prim-c-code 2@ type  \      prim prim-c-code 2@ type
 \      ." }" cr  \      ." }" cr
 \      stores  \      stores
 \      fill-tos  \      fill-state
 \      ." return (sp);" cr  \      ." return (sp);" cr
 \      ." }" cr  \      ." }" cr
 \      cr ;  \      cr ;
Line 1244  variable tail-nextp2 \ xt to execute for Line 1311  variable tail-nextp2 \ xt to execute for
     compute-max-back-depths      compute-max-back-depths
     output-combined perform ;      output-combined perform ;
   
   \ reprocessing (typically to generate versions for another cache states)
   \ !! use prim-context
   
   variable reprocessed-num 0 reprocessed-num !
   
   : new-name ( -- c-addr u )
       reprocessed-num @ 0
       1 reprocessed-num +!
       <# #s 'p hold '_ hold #> save-mem ;
   
   : reprocess-simple ( prim -- )
       to prim
       new-name prim prim-c-name 2!
       output @ execute ;
   
   : lookup-prim ( c-addr u -- prim )
       primitives search-wordlist 0= -13 and throw execute ;
   
   : state-prim1 { in-state out-state prim -- }
       in-state out-state state-default dup d= ?EXIT
       in-state  to state-in
       out-state to state-out
       prim reprocess-simple ;
   
   : state-prim ( in-state out-state "name" -- )
       parse-word lookup-prim state-prim1 ;
   
   \ reprocessing with default states
   
   \ This is a simple scheme and should be generalized
   \ assumes we only cache one stack and use simple states for that
   
   0 value cache-stack  \ stack that we cache
   2variable cache-states \ states of the cache, starting with the empty state
   
   : compute-default-state-out ( n-in -- n-out )
       \ for the current prim
       cache-stack stack-in @ - 0 max
       cache-stack stack-out @ + cache-states 2@ nip 1- min ;
   
   : gen-prim-states ( prim -- )
       to prim
       cache-states 2@ swap { states } ( nstates )
       cache-stack stack-in @ +do
           states i th @
           states i compute-default-state-out th @
           prim state-prim1
       loop ;
   
   : prim-states ( "name" -- )
       parse-word lookup-prim gen-prim-states ;
   
   : gen-branch-states ( prim -- )
       \ generate versions that produce state-default; useful for branches
       to prim
       cache-states 2@ swap { states } ( nstates )
       cache-stack stack-in @ +do
           states i th @ state-default prim state-prim1
       loop ;
   
   : branch-states ( out-state "name" -- )
       parse-word lookup-prim gen-branch-states ;
   
   \ producing state transitions
   
   : gen-transitions ( "name" -- )
       parse-word lookup-prim { prim }
       cache-states 2@ { states nstates }
       nstates 0 +do
           nstates 0 +do
               i j <> if
                   states i th @ states j th @ prim state-prim1
               endif
           loop
       loop ;
   
 \ C output  \ C output
   
 : print-item { n stack -- }  : print-item { n stack -- }
Line 1312  variable tail-nextp2 \ xt to execute for Line 1455  variable tail-nextp2 \ xt to execute for
     ." DEF_CA" cr      ." DEF_CA" cr
     print-declarations-combined      print-declarations-combined
     ." NEXT_P0;" cr      ." NEXT_P0;" cr
     flush-tos      spill-state
     \ fetches \ now in parts      \ fetches \ now in parts
     \ print-debug-args      \ print-debug-args
     \ stack-pointer-updates now in parts      \ stack-pointer-updates now in parts
Line 1396  variable offset-super2  0 offset-super2 Line 1539  variable offset-super2  0 offset-super2
 : output-costs-prefix ( -- )  : output-costs-prefix ( -- )
     ." {" prim compute-costs      ." {" prim compute-costs
     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-out state-number @ 2 .r ." ," ;
   
 : output-costs-gforth-simple ( -- )  : output-costs-gforth-simple ( -- )
     output-costs-prefix      output-costs-prefix
Removed from v.1.3  
changed lines
  Added in v.1.8

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>