[gforth] / gforth / prims2x0.6.2.fs  

gforth: gforth/prims2x0.6.2.fs

Diff for /gforth/prims2x0.6.2.fs between version 1.3 and 1.9

version 1.3, Sun Jan 18 18:41:55 2009 UTC version 1.9, Thu Dec 31 15:32:35 2009 UTC
Line 1 
Line 1 
 \ converts primitives to, e.g., C code  \ converts primitives to, e.g., C code
   
 \ Copyright (C) 1995,1996,1997,1998,2000,2003,2008 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,2000,2003,2008,2009 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 54 
Line 54 
 \ for backwards compatibility, jaw  \ for backwards compatibility, jaw
 require compat/strcomp.fs  require compat/strcomp.fs
   
   [undefined] endtry-iferror [if]
       : endtry-iferror postpone recover ; immediate compile-only
   [then]
   
 warnings off  warnings off
   
 \ redefinitions of kernel words not present in gforth-0.6.1  \ redefinitions of kernel words not present in gforth-0.6.1
Line 71 
Line 75 
   
 include ./gray.fs  include ./gray.fs
 128 constant max-effect \ number of things on one side of a stack effect  128 constant max-effect \ number of things on one side of a stack effect
 4 constant max-stacks  \ the max. number of stacks (including inst-stream).  9 constant max-stacks  \ the max. number of stacks (including inst-stream).
 255 constant maxchar  255 constant maxchar
 maxchar 1+ constant eof-char  maxchar 1+ constant eof-char
 #tab constant tab-char  #tab constant tab-char
Line 302 
Line 306 
 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 part: array[parts] 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  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  \ maximum depth from end of the combination to the start of the each part
   create depths max-stacks max-combined 1+ * cells allot
   \ depth at the start of each part: array[parts] of array[stack]
   
 : s-c-max-depth ( nstack ncomponent -- addr )  : s-c-max-depth ( nstack ncomponent -- addr )
     max-stacks * + cells max-depths + ;      max-stacks * + cells max-depths + ;
Line 310 
Line 316 
 : s-c-max-back-depth ( nstack ncomponent -- addr )  : s-c-max-back-depth ( nstack ncomponent -- addr )
     max-stacks * + cells max-back-depths + ;      max-stacks * + cells max-back-depths + ;
   
   : s-c-depth  ( nstack ncomponent -- addr )
       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 }
       \ does the stack reach its final maxdepth before the component?
       nstack ncomponent s-c-max-depth @
       nstack num-combined @ s-c-max-depth @ = ;
   
 wordlist constant primitives  wordlist constant primitives
   
 : create-prim ( prim -- )  : create-prim ( prim -- )
Line 669 
Line 694 
 : 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?
     ['] fill-a-tos map-stacks1 ;      ['] fill-a-tos map-stacks1 ;
Line 692 
Line 719 
     stack-access-transform @ dup >r execute      stack-access-transform @ dup >r execute
     0 r> execute - ;      0 r> execute - ;
   
 : stack-pointer-update { stack -- }  : n-stack-pointer-update { n stack -- }
     \ stacks grow downwards      \ stack pointer update by n
     stack stack-diff      n 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(" n 0 .r ." );" cr
         else          else
             stack stack-pointer 2@ type ."  += "              stack stack-pointer 2@ type ."  += "
             stack stack-update-transform 0 .r ." ;" cr              n stack stack-update-transform 0 .r ." ;" cr
         endif          endif
     endif ;      endif ;
   
   : stack-pointer-update { stack -- }
       \ stacks grow downwards
       stack stack-diff stack n-stack-pointer-update ;
   
 : stack-pointer-updates ( -- )  : stack-pointer-updates ( -- )
     ['] stack-pointer-update map-stacks ;      ['] stack-pointer-update map-stacks ;
   
Line 781 
Line 811 
 : 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 1094 
Line 1121 
         current-depth i th !          current-depth i th !
     loop ;      loop ;
   
 : copy-maxdepths ( n -- )  : copy-maxdepths { n -- }
     max-depth max-depths rot max-stacks * th max-stacks cells move ;      \ transfer current-depth to depths and max-depth to max-depths
       max-depth max-depths n max-stacks * th max-stacks cells move
       current-depth depths n 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
Line 1190 
Line 1219 
     print-debug-results      print-debug-results
     stores ;      stores ;
   
   : 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 @ ;
   
   : 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 part-stack-access ." ;" cr
       loop ;
   
   : combined-tail-stores ( -- )
       \ All the stores we have yet to do on an INST_TAIL that are the
       \ result of earlier parts (and will be consumed by other parts in
       \ the fallthrough path, and thus have not been stored in the
       \ earlier part).
       ['] stack-combined-tail-stores map-stacks ;
   
   : combined-tail-stack-pointer-update-n { stack -- }
       stack stack-number @ { nstack }
       nstack part-num @ 1+ s-c-depth @ ( nupdate-raw )
       \ correct for possible earlier update
       nstack part-num @ 1+ final-max-depth? if
           stack combined ['] stack-diff prim-context -
       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-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
     part-output-c-tail      part-output-c-tail
       combined-tail-stores
     combined ['] output-c-tail-no-stores prim-context      combined ['] output-c-tail-no-stores prim-context
     r> in-part ! ;      r> in-part ! ;
   
 : part-stack-pointer-updates ( -- )  : part-stack-pointer-updates ( -- )
     next-stack-number @ 0 +do      next-stack-number @ 0 +do
         i part-num @ 1+ s-c-max-depth @ dup          i part-num @ 1+ final-max-depth? \ reached afterwards
         i num-combined @ s-c-max-depth @ =    \ final depth          i part-num @ final-max-depth? 0= \ but not before
         swap i part-num @ s-c-max-depth @ <> \ just reached now          part-num @ 0= \ exception: first part
         part-num @ 0= \ first part  
         or and if          or and if
             stacks i th @ stack-pointer-update              stacks i th @ stack-pointer-update
         endif          endif
Line 1216 
Line 1310 
     part-fetches      part-fetches
     print-debug-args      print-debug-args
     combined ['] part-stack-pointer-updates prim-context      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
       1 part-num +!
     part-output-c-tail      part-output-c-tail
     ." }" cr ;      ." }" cr ;
   

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help