[gforth] / gforth / prims2x.fs  

gforth: gforth/prims2x.fs

Diff for /gforth/prims2x.fs between version 1.117 and 1.118

version 1.117, Fri Oct 4 19:17:05 2002 UTC version 1.118, Sat Oct 12 11:05:22 2002 UTC
Line 197 
Line 197 
     ['] stack-in-index r> stack-in-index-xt ! ;      ['] stack-in-index r> stack-in-index-xt ! ;
   
 : map-stacks { xt -- }  : map-stacks { xt -- }
       \ perform xt for all stacks
       next-stack-number @ 0 +do
           stacks i th @ xt execute
       loop ;
   
   : map-stacks1 { xt -- }
     \ perform xt for all stacks except inst-stream      \ perform xt for all stacks except inst-stream
     next-stack-number @ 1 +do      next-stack-number @ 1 +do
         stacks i th @ xt execute          stacks i th @ xt execute
Line 251 
Line 257 
 variable in-part \ true if processing a part  variable in-part \ true if processing a part
  in-part off   in-part off
   
   : prim-context ( ... p xt -- ... )
       \ execute xt with prim set to p
       prim >r
       swap to prim
       catch
       r> to prim
       throw ;
   
 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
   variable part-num \ current part number during process-combined
   
 : map-combined { xt -- }  : map-combined { xt -- }
     \ perform xt for all components of the current combined instruction      \ perform xt for all components of the current combined instruction
Line 268 
Line 283 
 create max-depth     max-stacks cells allot  create max-depth     max-stacks cells allot
 create min-depth     max-stacks cells allot  create min-depth     max-stacks cells allot
   
   create sp-update-in max-stacks cells allot
   \ where max-depth occured the first time
   create max-depths max-stacks max-combined 1+ * cells allot
   \ maximum depth at start of each component: array[components] of array[stack]
   
   : s-c-max-depth ( nstack ncomponent -- addr )
       max-stacks * + cells max-depths + ;
   
 wordlist constant primitives  wordlist constant primitives
   
 : create-prim ( prim -- )  : create-prim ( prim -- )
Line 311 
Line 334 
 \ forward declaration for inst-stream (breaks cycle in definitions)  \ forward declaration for inst-stream (breaks cycle in definitions)
 defer inst-stream-f ( -- stack )  defer inst-stream-f ( -- stack )
   
   : stack-depth { stack -- n }
       current-depth stack stack-number @ th @ ;
   
 : part-stack-access { n stack -- }  : part-stack-access { n stack -- }
     \ print _<stack><x>, x=inst-stream? n : maxdepth-currentdepth-n-1      \ print _<stack><x>, x=inst-stream? n : maxdepth-currentdepth-n-1
     ." _" stack stack-pointer 2@ type      ." _" stack stack-pointer 2@ type
     stack stack-number @ { stack# }      stack stack-number @ { stack# }
     current-depth stack# th @ n + { access-depth }      stack stack-depth n + { access-depth }
     stack inst-stream-f = if      stack inst-stream-f = if
         access-depth          access-depth
     else      else
Line 325 
Line 351 
     endif      endif
     0 .r ;      0 .r ;
   
 : stack-access ( n stack -- )  : part-stack-read { n stack -- }
       stack stack-depth n + ( ndepth )
       stack stack-number @ part-num @ s-c-max-depth @
   \    max-depth stack stack-number @ th @ ( ndepth nmaxdepth )
       over <= if ( ndepth ) \ load from memory
           stack normal-stack-access
       else
           drop n stack part-stack-access
       endif ;
   
   : part-stack-write ( n stack -- )
       part-stack-access ;
   
   : stack-read ( n stack -- )
     \ print a stack access at index n of stack      \ print a stack access at index n of stack
     in-part @ if      in-part @ if
         part-stack-access          part-stack-read
       else
           normal-stack-access
       endif ;
   
   : stack-write ( n stack -- )
       \ print a stack access at index n of stack
       in-part @ if
           part-stack-write
     else      else
         normal-stack-access          normal-stack-access
     endif ;      endif ;
Line 346 
Line 393 
     >r      >r
     ." vm_" r@ item-stack-type-name type      ." vm_" r@ item-stack-type-name type
     ." 2" r@ item-type @ print-type-prefix ." ("      ." 2" r@ item-type @ print-type-prefix ." ("
     r@ item-in-index r@ item-stack @ stack-access ." ,"      r@ item-in-index r@ item-stack @ stack-read ." ,"
     r@ item-name 2@ type      r@ item-name 2@ type
     ." );" cr      ." );" cr
     rdrop ;      rdrop ;
Line 357 
Line 404 
     ." vm_two"      ." vm_two"
     r@ item-stack-type-name type ." 2"      r@ item-stack-type-name type ." 2"
     r@ item-type @ print-type-prefix ." ("      r@ item-type @ print-type-prefix ." ("
     r@ item-in-index r@ item-stack @ 2dup ." (Cell)" stack-access      r@ item-in-index r@ item-stack @ 2dup ." (Cell)" stack-read
     ." , "                      -1 under+ ." (Cell)" stack-access      ." , "                      -1 under+ ." (Cell)" stack-read
     ." , " r@ item-name 2@ type      ." , " r@ item-name 2@ type
     ." )" cr      ." )" cr
     rdrop ;      rdrop ;
Line 390 
Line 437 
     r@ item-type @ print-type-prefix ." 2"      r@ item-type @ print-type-prefix ." 2"
     r@ item-stack-type-name type ." ("      r@ item-stack-type-name type ." ("
     r@ item-name 2@ type ." ,"      r@ item-name 2@ type ." ,"
     r@ item-out-index r@ item-stack @ stack-access ." );"      r@ item-out-index r@ item-stack @ stack-write ." );"
     rdrop ;      rdrop ;
   
 : store-single ( item -- )  : store-single ( item -- )
     >r      >r
     store-optimization @ r@ same-as-in? and if      store-optimization @ in-part @ 0= and r@ same-as-in? and if
         r@ item-in-index 0= r@ item-out-index 0= xor if          r@ item-in-index 0= r@ item-out-index 0= xor if
             ." IF_" r@ item-stack @ stack-pointer 2@ type              ." IF_" r@ item-stack @ stack-pointer 2@ type
             ." TOS(" r@ really-store-single ." );" cr              ." TOS(" r@ really-store-single ." );" cr
Line 412 
Line 459 
  r@ item-type @ print-type-prefix ." 2two"   r@ item-type @ print-type-prefix ." 2two"
  r@ item-stack-type-name type ." ("   r@ item-stack-type-name type ." ("
  r@ item-name 2@ type ." , "   r@ item-name 2@ type ." , "
  r@ item-out-index r@ item-stack @ 2dup stack-access   r@ item-out-index r@ item-stack @ 2dup stack-write
  ." , "                       -1 under+ stack-access   ." , "                       -1 under+ stack-write
  ." )" cr   ." )" cr
  rdrop ;   rdrop ;
   
Line 552 
Line 599 
 : compute-offset-out ( addr1 addr2 -- )  : compute-offset-out ( addr1 addr2 -- )
     ['] stack-out compute-offset ;      ['] stack-out compute-offset ;
   
 : clear-stack { -- }  : clear-stack ( stack -- )
     dup stack-in off stack-out off ;      dup stack-in off stack-out off ;
   
 : compute-offsets ( -- )  : compute-offsets ( -- )
     ['] clear-stack map-stacks      ['] clear-stack map-stacks
     inst-stream clear-stack  
     prim prim-effect-in  prim prim-effect-in-end  @ ['] compute-offset-in  map-items      prim prim-effect-in  prim prim-effect-in-end  @ ['] compute-offset-in  map-items
     prim prim-effect-out prim prim-effect-out-end @ ['] compute-offset-out map-items      prim prim-effect-out prim prim-effect-out-end @ ['] compute-offset-out map-items
     inst-stream stack-out @ 0= s" # can only be on the input side" ?print-error ;      inst-stream stack-out @ 0= s" # can only be on the input side" ?print-error ;
Line 576 
Line 622 
     endif ;      endif ;
   
 : flush-tos ( -- )  : flush-tos ( -- )
     ['] flush-a-tos map-stacks ;      ['] flush-a-tos map-stacks1 ;
   
 : fill-a-tos { stack -- }  : fill-a-tos { stack -- }
     stack stack-out @ 0= stack stack-in @ 0<> and      stack stack-out @ 0= stack stack-in @ 0<> and
Line 587 
Line 633 
   
 : fill-tos ( -- )  : fill-tos ( -- )
     \ !! inst-stream for prefetching?      \ !! inst-stream for prefetching?
     ['] fill-a-tos map-stacks ;      ['] fill-a-tos map-stacks1 ;
   
 : fetch ( addr -- )  : fetch ( addr -- )
     dup item-type @ type-fetch @ execute ;      dup item-type @ type-fetch @ execute ;
Line 595 
Line 641 
 : 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      \ stack grow downwards
     stack stack-in @ stack stack-out @ -      stack stack-in @ stack stack-out @ -
     ?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
               inst-pointer-update
           else
         stack stack-pointer 2@ type ."  += " 0 .r ." ;" cr          stack stack-pointer 2@ type ."  += " 0 .r ." ;" cr
     endif ;          endif
   
 : inst-pointer-update ( -- )  
     inst-stream stack-in @ ?dup-if  
         ." INC_IP(" 0 .r ." );" cr  
     endif ;      endif ;
   
 : stack-pointer-updates ( -- )  : stack-pointer-updates ( -- )
     inst-pointer-update  
     ['] stack-pointer-update map-stacks ;      ['] stack-pointer-update map-stacks ;
   
 : store ( item -- )  : store ( item -- )
Line 980 
Line 1029 
         current-depth i th !          current-depth i th !
     loop ;      loop ;
   
   : copy-maxdepths ( n -- )
       max-depth max-depths rot max-stacks * th max-stacks cells move ;
   
 : add-prim ( addr u -- )  : add-prim ( addr u -- )
     \ add primitive given by "addr u" to combined-prims      \ add primitive given by "addr u" to combined-prims
     primitives search-wordlist s" unknown primitive" ?print-error      primitives search-wordlist s" unknown primitive" ?print-error
     execute { p }      execute { p }
     p combined-prims num-combined @ th !      p combined-prims num-combined @ th !
       num-combined @ copy-maxdepths
     1 num-combined +!      1 num-combined +!
     p add-depths ;      p add-depths
       num-combined @ copy-maxdepths ;
   
 : compute-effects { q -- }  : compute-effects { q -- }
     \ compute the stack effects of q from the depths      \ compute the stack effects of q from the depths
Line 1051 
Line 1105 
   
 : output-combined-tail ( -- )  : output-combined-tail ( -- )
     part-output-c-tail      part-output-c-tail
     prim >r combined to prim  
     in-part @ >r in-part off      in-part @ >r in-part off
     output-c-tail      combined ['] output-c-tail prim-context
     r> in-part ! r> to prim ;      r> in-part ! ;
   
   : part-stack-pointer-updates ( -- )
       max-stacks 0 +do
           i part-num @ 1+ s-c-max-depth @ dup
           i num-combined @ s-c-max-depth @ =    \ final depth
           swap i part-num @ s-c-max-depth @ <> \ just reached now
           part-num @ 0= \ first part
           or and if
               stacks i th @ stack-pointer-update
           endif
       loop ;
   
 : output-part ( p -- )  : output-part ( p -- )
     to prim      to prim
Line 1064 
Line 1128 
     print-declarations      print-declarations
     part-fetches      part-fetches
     print-debug-args      print-debug-args
       combined ['] part-stack-pointer-updates prim-context
       1 part-num +!
     prim add-depths \ !! right place?      prim add-depths \ !! right place?
     prim prim-c-code 2@ ['] output-combined-tail type-c-code      prim prim-c-code 2@ ['] output-combined-tail type-c-code
     part-output-c-tail      part-output-c-tail
Line 1072 
Line 1138 
 : output-parts ( -- )  : output-parts ( -- )
     prim >r in-part on      prim >r in-part on
     current-depth max-stacks cells erase      current-depth max-stacks cells erase
       0 part-num !
     ['] output-part map-combined      ['] output-part map-combined
     in-part off      in-part off
     r> to prim ;      r> to prim ;
Line 1084 
Line 1151 
     print-declarations-combined      print-declarations-combined
     ." NEXT_P0;" cr      ." NEXT_P0;" cr
     flush-tos      flush-tos
     fetches      \ fetches \ now in parts
     \ print-debug-args      \ print-debug-args
     stack-pointer-updates      \ stack-pointer-updates now in parts
     output-parts      output-parts
     output-c-tail2      output-c-tail2
     ." }" cr      ." }" cr

Generate output suitable for use with a patch program
Legend:
Removed from v.1.117  
changed lines
  Added in v.1.118
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help