Diff for /gforth/prims2x0.6.2.fs between versions 1.6 and 1.7

version 1.6, 2009/02/17 20:48:47 version 1.7, 2009/02/20 19:33:24
Line 315  create depths max-stacks max-combined 1+ Line 315  create depths max-stacks max-combined 1+
 : s-c-depth  ( nstack ncomponent -- addr )  : s-c-depth  ( nstack ncomponent -- addr )
     max-stacks * + cells depths + ;      max-stacks * + cells depths + ;
   
   : print-depths1 { stack# xt -- }
       num-combined @ 1+ 0 +do
           stack# i xt execute @ 3 .r
       loop ;
   
   : print-depths { stack# -- }
       \ for debugging
       cr ."          depths: " stack# [']          s-c-depth print-depths1
       cr ."      max-depths: " stack# [']      s-c-max-depth print-depths1
       cr ." max-back-depths: " stack# ['] s-c-max-back-depth print-depths1 ;
   
 : final-max-depth? { nstack ncomponent -- flag }  : final-max-depth? { nstack ncomponent -- flag }
     \ does the stack reach its final maxdepth before the component?      \ does the stack reach its final maxdepth before the component?
     nstack ncomponent s-c-max-depth @      nstack ncomponent s-c-max-depth @
Line 679  stack inst-stream IP Cell Line 690  stack inst-stream IP Cell
 : flush-tos ( -- )  : flush-tos ( -- )
     ['] flush-a-tos map-stacks1 ;      ['] flush-a-tos map-stacks1 ;
   
 : fill-a-tos { stack -- }  : ?really-fill-a-tos { f stack -- }
     stack stack-out @ 0= stack stack-in @ 0<> and      f if
     if          ." IF_" stack stack-pointer 2@ 2dup type ." TOS("
         ." IF_" stack stack-pointer 2@ 2dup type ." TOS("          2dup type ." TOS = " type 0 stack normal-stack-access0 ." );" cr
         2dup type ." TOS = " type 0 stack normal-stack-access0 ." );" cr  
     endif ;      endif ;
       
   : fill-a-tos { stack -- }
       stack stack-out @ 0= stack stack-in @ 0<> and stack ?really-fill-a-tos ;
   
 : fill-tos ( -- )  : fill-tos ( -- )
     \ !! inst-stream for prefetching?      \ !! inst-stream for prefetching?
Line 794  variable tail-nextp2 \ xt to execute for Line 807  variable tail-nextp2 \ xt to execute for
 : output-c-tail2 ( -- )  : output-c-tail2 ( -- )
     ['] output-label2 output-c-tail1 ;      ['] output-label2 output-c-tail1 ;
   
 : output-c-tail-no-stores ( -- )  
     tail-nextp2 @ output-c-tail1-no-stores ;  
   
 : output-c-tail2-no-stores ( -- )  : output-c-tail2-no-stores ( -- )
     ['] output-label2 output-c-tail1-no-stores ;      ['] output-label2 output-c-tail1-no-stores ;
   
Line 1205  variable tail-nextp2 \ xt to execute for Line 1215  variable tail-nextp2 \ xt to execute for
     print-debug-results      print-debug-results
     stores ;      stores ;
   
 : stack-combined-tail-stores { stack -- }  : stack-combined-tail-stores-limits { stack -- nupper nlower }
     \ the top stack-out items of this part are stored elsewhere; so  
     \ this store everything between max-depth, unless it was stored  
     \ previously (below back-max-depth) and stack-out  
     stack stack-number @ part-num @ 2dup 2>r s-c-max-depth @       stack stack-number @ part-num @ 2dup 2>r s-c-max-depth @ 
     2r> s-c-max-back-depth @ min      2r> s-c-max-back-depth @ min
     stack stack-depth -      stack stack-depth -
     stack stack-out @ +do      stack stack-out @ ;
   
   : stack-combined-tail-stores { stack -- }
       \ the top stack-out items of this part are stored elsewhere; so
       \ this store everything between max-depth and stack-out, unless it
       \ was stored previously (below back-max-depth)
       stack stack-combined-tail-stores-limits +do
         i stack normal-stack-access ."  = "          i stack normal-stack-access ."  = "
         i stack part-stack-access ." ;" cr          i stack part-stack-access ." ;" cr
     loop ;      loop ;
Line 1224  variable tail-nextp2 \ xt to execute for Line 1237  variable tail-nextp2 \ xt to execute for
     \ earlier part).      \ earlier part).
     ['] stack-combined-tail-stores map-stacks ;      ['] stack-combined-tail-stores map-stacks ;
   
 : combined-tail-stack-pointer-update { stack -- }  : combined-tail-stack-pointer-update-n { stack -- }
     stack stack-number @ { nstack }      stack stack-number @ { nstack }
     nstack part-num @ 1+ s-c-depth @ ( nupdate-raw )      nstack part-num @ 1+ s-c-depth @ ( nupdate-raw )
     \ correct for possible earlier update      \ correct for possible earlier update
     nstack part-num @ 1+ final-max-depth? if      nstack part-num @ 1+ final-max-depth? if
         stack combined ['] stack-diff prim-context - endif          stack combined ['] stack-diff prim-context -
     stack n-stack-pointer-update ;      endif ;
   
   : combined-tail-stack-pointer-update { stack -- }
       stack combined-tail-stack-pointer-update-n stack n-stack-pointer-update ;
   
 : combined-tail-stack-pointer-updates ( -- )  : combined-tail-stack-pointer-updates ( -- )
     ['] combined-tail-stack-pointer-update map-stacks ;      ['] combined-tail-stack-pointer-update map-stacks ;
   
   : stack-combined-tail-stores-limits { stack -- nupper nlower }
       stack stack-number @ part-num @ 2dup 2>r s-c-max-depth @ 
       2r> s-c-max-back-depth @ min
       stack stack-depth -
       stack stack-out @ ;
   
   : tail-fill-a-tos { stack -- }
       \ 1 print-depths
       stack stack-number @ part-num @ 2dup s-c-max-depth @ { scmde }
       1+ 2dup s-c-max-depth @ { scmd } s-c-depth @ { scd }
       scmd scd = scmd 0<> and \ normal fill (TOS consumed)
       \ or it was stored to (what's now) sp[0] by an earlier part:
       stack stack-combined-tail-stores-limits <= \ no stores in this tail
       scmde 0= and \ there were stores to this stack earlier
       stack combined-tail-stack-pointer-update-n 0<> and \ but not to spTOS
       or stack ?really-fill-a-tos ;
   
   : tail-fill-tos ( -- )
       \ fill tos in INST_TAIL
       ['] tail-fill-a-tos map-stacks1 ;
   
   : output-c-tail-no-stores ( -- )
       \ the final part of INST_TAIL
       output-super-end
       ." NEXT_P1;" cr
       tail-fill-tos 
       tail-nextp2 perform ;
   
 : output-combined-tail ( -- )  : output-combined-tail ( -- )
     in-part @ >r in-part off      in-part @ >r in-part off
     combined-tail-stack-pointer-updates      combined-tail-stack-pointer-updates

Removed from v.1.6  
changed lines
  Added in v.1.7


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